home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 14 / hacker14.iso / programacao / visual / perl.exe / {app} / Library / Perl / Tidy.pm < prev    next >
Encoding:
Perl POD Document  |  2002-11-30  |  832.9 KB  |  23,818 lines
  1. ############################################################
  2. #
  3. #    perltidy - a perl script indenter and formatter
  4. #
  5. #    Copyright (c) 2000, 2001, 2002 by Steve Hancock
  6. #    Distributed under the GPL license agreement; see file COPYING
  7. #
  8. #    This program is free software; you can redistribute it and/or modify
  9. #    it under the terms of the GNU General Public License as published by
  10. #    the Free Software Foundation; either version 2 of the License, or
  11. #    (at your option) any later version.
  12. #
  13. #    This program is distributed in the hope that it will be useful,
  14. #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. #    GNU General Public License for more details.
  17. #
  18. #    You should have received a copy of the GNU General Public License
  19. #    along with this program; if not, write to the Free Software
  20. #    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  21. #
  22. #    For brief instructions instructions, try 'perltidy -h'.
  23. #    For more complete documentation, try 'man perltidy'
  24. #    or visit http://perltidy.sourceforge.net
  25. #
  26. #    This script is an example of the default style.  It was formatted with:
  27. #
  28. #      perltidy -olc perltidy
  29. #
  30. #    Code Contributions:
  31. #      Michael Cartmell supplied code for adaptation to VMS and helped with
  32. #        v-strings.
  33. #      Hugh S. Myers supplied sub streamhandle and the supporting code to
  34. #        create a Perl::Tidy module which can operate on strings, arrays, etc.
  35. #      Yves Orton supplied coding to help detect Windows versions.
  36. #      Axel Rose supplied a patch for MacPerl.
  37. #      Many others have supplied key ideas, suggestions, and bug reports;
  38. #        see the CHANGES file.
  39. #
  40. ############################################################
  41.  
  42. package Perl::Tidy;
  43. use 5.004;    # need IO::File from 5.004 or later
  44. BEGIN { $^W = 1; }    # turn on warnings
  45.  
  46. use strict;
  47. use Exporter;
  48. use Carp;
  49.  
  50. use vars qw{
  51.   $VERSION
  52.   @ISA
  53.   @EXPORT
  54.   $missing_file_spec
  55. };
  56.  
  57. @ISA    = qw( Exporter );
  58. @EXPORT = qw( &perltidy );
  59.  
  60. use IO::File;
  61. use File::Basename;
  62.  
  63. BEGIN {
  64.     ( $VERSION = q($Id: Tidy.pm,v 1.36 2002/11/30 15:05:23 perltidy Exp $) ) =~ s/^.*\s+(\d+)\/(\d+)\/(\d+).*$/$1$2$3/; # all one line for MakeMaker
  65. }
  66.  
  67. sub streamhandle {
  68.  
  69.     # given filename and mode (r or w), create an object which:
  70.     #   has a 'getline' method if mode='r', and
  71.     #   has a 'print' method if mode='w'.
  72.     # The objects also need a 'close' method.
  73.     #
  74.     # How the object is made:
  75.     #
  76.     # if $filename is:     Make object using:
  77.     # ----------------     -----------------
  78.     # '-'                  (STDIN if mode = 'r', STDOUT if mode='w')
  79.     # string               IO::File
  80.     # ARRAY  ref           Perl::Tidy::IOScalarArray (formerly IO::ScalarArray)
  81.     # STRING ref           Perl::Tidy::IOScalar      (formerly IO::Scalar)
  82.     # object               object
  83.     #                      (check for 'print' method for 'w' mode)
  84.     #                      (check for 'getline' method for 'r' mode)
  85.     my $ref = ref( my $filename = shift );
  86.     my $mode = shift;
  87.     my $New;
  88.     my $fh;
  89.  
  90.     # handle a reference
  91.     if ($ref) {
  92.         if ( $ref eq 'ARRAY' ) {
  93.             $New = sub { Perl::Tidy::IOScalarArray->new(@_) };
  94.         }
  95.         elsif ( $ref eq 'SCALAR' ) {
  96.             $New = sub { Perl::Tidy::IOScalar->new(@_) };
  97.         }
  98.         else {
  99.  
  100.             # Accept an object with a getline method for reading. Note:
  101.             # IO::File is built-in and does not respond to the defined
  102.             # operator.  If this causes trouble, the check can be
  103.             # skipped and we can just let it crash if there is no
  104.             # getline.
  105.             if ( $mode =~ /[rR]/ ) {
  106.                 if ( $ref eq 'IO::File' || defined &{ $ref . "::getline" } ) {
  107.                     $New = sub { $filename };
  108.                 }
  109.                 else {
  110.                     $New = sub { undef };
  111.                     confess <<EOM;
  112. ------------------------------------------------------------------------
  113. No 'getline' method is defined for object of class $ref
  114. Please check your call to Perl::Tidy::perltidy.  Trace follows.
  115. ------------------------------------------------------------------------
  116. EOM
  117.                 }
  118.             }
  119.  
  120.             # Accept an object with a print method for writing.
  121.             # See note above about IO::File
  122.             if ( $mode =~ /[wW]/ ) {
  123.                 if ( $ref eq 'IO::File' || defined &{ $ref . "::print" } ) {
  124.                     $New = sub { $filename };
  125.                 }
  126.                 else {
  127.                     $New = sub { undef };
  128.                     confess <<EOM;
  129. ------------------------------------------------------------------------
  130. No 'print' method is defined for object of class $ref
  131. Please check your call to Perl::Tidy::perltidy. Trace follows.
  132. ------------------------------------------------------------------------
  133. EOM
  134.                 }
  135.             }
  136.         }
  137.     }
  138.  
  139.     # handle a string
  140.     else {
  141.         if ( $filename eq '-' ) {
  142.             $New = sub { $mode eq 'w' ? *STDOUT : *STDIN }
  143.         }
  144.         else {
  145.             $New = sub { IO::File->new(@_) };
  146.         }
  147.     }
  148.     $fh = $New->( $filename, $mode )
  149.       or warn "Couldn't open file:$filename in mode:$mode : $!\n";
  150.     return $fh, ( $ref or $filename );
  151. }
  152.  
  153. sub catfile {
  154.  
  155.     # concatenate a path and file basename
  156.     # returns undef in case of error
  157.  
  158.     BEGIN { eval "require File::Spec"; $missing_file_spec = $@; }
  159.  
  160.     # use File::Spec if we can
  161.     unless ($missing_file_spec) {
  162.         return File::Spec->catfile(@_);
  163.     }
  164.  
  165.     # Perl 5.004 systems may not have File::Spec so we'll make
  166.     # a simple try.  We assume File::Basename is available.
  167.     # return undef if not successful.
  168.     my $name      = pop @_;
  169.     my $path      = join '/', @_;
  170.     my $test_file = $path . $name;
  171.     my ( $test_name, $test_path ) = fileparse($test_file);
  172.     return $test_file if ( $test_name eq $name );
  173.     return undef      if ( $^O        eq 'VMS' );
  174.  
  175.     # this should work at least for Windows and Unix:
  176.     $test_file = $path . '/' . $name;
  177.     ( $test_name, $test_path ) = fileparse($test_file);
  178.     return $test_file if ( $test_name eq $name );
  179.     return undef;
  180. }
  181.  
  182. sub make_temporary_filename {
  183.  
  184.     # Make a temporary filename.
  185.     #
  186.     # The POSIX tmpnam() function tends to be unreliable for non-unix
  187.     # systems (at least for the win32 systems that I've tested), so use
  188.     # a pre-defined name.  A slight disadvantage of this is that two
  189.     # perltidy runs in the same working directory may conflict.
  190.     # However, the chance of that is small and managable by the user.
  191.     # An alternative would be to check for the file's existance and use,
  192.     # say .TMP0, .TMP1, etc, but that scheme has its own problems.  So,
  193.     # keep it simple.
  194.     my $name = "perltidy.TMP";
  195.     if ( $^O =~ /win32|dos/i || $^O eq 'VMS' || $^O eq 'MacOs' ) {
  196.         return $name;
  197.     }
  198.     eval "use POSIX qw(tmpnam)";
  199.     if ($@) { return $name }
  200.     use IO::File;
  201.  
  202.     # just make a couple of tries before giving up and using the default
  203.     for ( 0 .. 1 ) {
  204.         my $tmpname = tmpnam();
  205.         my $fh = IO::File->new( $tmpname, O_RDWR | O_CREAT | O_EXCL );
  206.         if ($fh) {
  207.             $fh->close();
  208.             return ($tmpname);
  209.             last;
  210.         }
  211.     }
  212.     return ($name);
  213. }
  214.  
  215. # Here is a map of the flow of data from the input source to the output
  216. # line sink:
  217. #
  218. # LineSource-->Tokenizer-->Formatter-->VerticalAligner-->FileWriter-->
  219. #       input                         groups                 output
  220. #       lines   tokens      lines       of     lines          lines
  221. #                                      lines
  222. #
  223. # The names correspond to the package names responsible for the unit processes.
  224. #
  225. # The overall process is controlled by the "main" package.
  226. #
  227. # LineSource is the stream of input lines
  228. #
  229. # Tokenizer analyzes a line and breaks it into tokens, peeking ahead
  230. # if necessary.  A token is any section of the input line which should be
  231. # manipulated as a single entity during formatting.  For example, a single
  232. # ',' character is a token, and so is an entire side comment.  It handles
  233. # the complexities of Perl syntax, such as distinguishing between '<<' as
  234. # a shift operator and as a here-document, or distinguishing between '/'
  235. # as a divide symbol and as a pattern delimiter.
  236. #
  237. # Formatter inserts and deletes whitespace between tokens, and breaks
  238. # sequences of tokens at appropriate points as output lines.  It bases its
  239. # decisions on the default rules as modified by any command-line options.
  240. #
  241. # VerticalAligner collects groups of lines together and tries to line up
  242. # certain tokens, such as '=>', '#', and '=' by adding whitespace.
  243. #
  244. # FileWriter simply writes lines to the output stream.
  245. #
  246. # The Logger package, not shown, records significant events and warning
  247. # messages.  It writes a .LOG file, which may be saved with a
  248. # '-log' or a '-g' flag.
  249. #
  250. # Some comments in this file refer to separate test files, most of which
  251. # are in the test directory which can be downloaded in addition to the
  252. # basic perltidy distribution.
  253.  
  254. {
  255.  
  256.     # variables needed by interrupt handler:
  257.     my $tokenizer;
  258.     my $input_file;
  259.  
  260.     # this routine may be called to give a status report if interrupted.  If a
  261.     # parameter is given, it will call exit with that parameter.  This is no
  262.     # longer used because it works under Unix but not under Windows.
  263.     sub interrupt_handler {
  264.  
  265.         my $exit_flag = shift;
  266.         print STDERR "perltidy interrupted";
  267.         if ($tokenizer) {
  268.             my $input_line_number =
  269.               Perl::Tidy::Tokenizer::get_input_line_number();
  270.             print STDERR " at line $input_line_number";
  271.         }
  272.         if ($input_file) {
  273.  
  274.             if ( ref $input_file ) { print STDERR " of reference to:" }
  275.             else { print STDERR " of file:" }
  276.             print STDERR " $input_file";
  277.         }
  278.         print STDERR "\n";
  279.         exit $exit_flag if defined($exit_flag);
  280.     }
  281.  
  282.     sub perltidy {
  283.  
  284.         my %defaults = (
  285.             argv        => undef,
  286.             destination => undef,
  287.             formatter   => undef,
  288.             logfile     => undef,
  289.             errorfile   => undef,
  290.             perltidyrc  => undef,
  291.             source      => undef,
  292.             stderr      => undef,
  293.         );
  294.  
  295.         my %input_hash = @_;
  296.         if ( my @bad_keys = grep { !exists $defaults{$_} } keys %input_hash ) {
  297.             local $" = ')(';
  298.             my @good_keys = sort keys %defaults;
  299.             @bad_keys = sort @bad_keys;
  300.             confess <<EOM;
  301. ------------------------------------------------------------------------
  302. Unknown perltidy parameter : (@bad_keys)
  303. perltidy only understands : (@good_keys)
  304. ------------------------------------------------------------------------
  305.  
  306. EOM
  307.         }
  308.  
  309.         %input_hash = ( %defaults, %input_hash );
  310.         my $argv               = $input_hash{'argv'};
  311.         my $destination_stream = $input_hash{'destination'};
  312.         my $errorfile_stream   = $input_hash{'errorfile'};
  313.         my $logfile_stream     = $input_hash{'logfile'};
  314.         my $perltidyrc_stream  = $input_hash{'perltidyrc'};
  315.         my $source_stream      = $input_hash{'source'};
  316.         my $stderr_stream      = $input_hash{'stderr'};
  317.         my $user_formatter     = $input_hash{'formatter'};
  318.  
  319.         # future checks on $user_formatter go here
  320.         if ($user_formatter) {
  321.         }
  322.  
  323.         # see if ARGV is overridden
  324.         if ($argv) {
  325.  
  326.             my $rargv = ref $argv;
  327.             if ( $rargv eq 'SCALAR' ) { $argv = $$argv; $rargv = undef }
  328.  
  329.             # ref to ARRAY
  330.             if ($rargv) {
  331.                 if ( $rargv eq 'ARRAY' ) {
  332.                     @ARGV = @$argv;
  333.                 }
  334.                 else {
  335.                     croak <<EOM;
  336. ------------------------------------------------------------------------
  337. Please check value of -argv in call to perltidy;
  338. it must be a string or ref to ARRAY but is: $rargv
  339. ------------------------------------------------------------------------
  340. EOM
  341.                 }
  342.             }
  343.  
  344.             # string
  345.             else {
  346.                 my ( $rargv, $msg ) = parse_args($argv);
  347.                 if ($msg) {
  348.                     die <<EOM;
  349. Error parsing this string passed to to perltidy with 'argv': 
  350. $msg
  351. EOM
  352.                 }
  353.                 @ARGV = @{$rargv};
  354.             }
  355.         }
  356.  
  357.         # redirect STDERR if requested
  358.         if ($stderr_stream) {
  359.             my ( $fh_stderr, $stderr_file ) =
  360.               Perl::Tidy::streamhandle( $stderr_stream, 'w' );
  361.             if ($fh_stderr) { *STDERR = $fh_stderr }
  362.             else {
  363.                 croak <<EOM;
  364. ------------------------------------------------------------------------
  365. Unable to redirect STDERR to $stderr_stream
  366. Please check value of -stderr in call to perltidy
  367. ------------------------------------------------------------------------
  368. EOM
  369.             }
  370.         }
  371.  
  372.         my $rpending_complaint;
  373.         $$rpending_complaint = "";
  374.         my $rpending_logfile_message;
  375.         $$rpending_logfile_message = "";
  376.  
  377.         my ( $is_Windows, $Windows_type ) =
  378.           look_for_Windows($rpending_complaint);
  379.  
  380.         # VMS file names are restricted to a 40.40 format, so we append _tdy
  381.         # instead of .tdy, etc. (but see also sub check_vms_filename)
  382.         my $dot;
  383.         my $dot_pattern;
  384.         if ( $^O eq 'VMS' ) {
  385.             $dot         = '_';
  386.             $dot_pattern = '_';
  387.         }
  388.         else {
  389.             $dot         = '.';
  390.             $dot_pattern = '\.';    # must escape for use in regex
  391.         }
  392.  
  393.         # handle command line options
  394.         my ( $rOpts, $config_file, $rraw_options, $saw_extrude ) =
  395.           process_command_line(
  396.             $perltidyrc_stream, $is_Windows,
  397.             $Windows_type,      $rpending_complaint
  398.           );
  399.  
  400.         # there must be one entry here for every possible format
  401.         my %default_file_extension = (
  402.             tidy => 'tdy',
  403.             html => 'html',
  404.             user => '',
  405.         );
  406.  
  407.         # be sure we have a valid output format
  408.         unless ( exists $default_file_extension{ $rOpts->{'format'} } ) {
  409.             my $formats = join ' ',
  410.               sort map { "'" . $_ . "'" } keys %default_file_extension;
  411.             my $fmt = $rOpts->{'format'};
  412.             die "-format='$fmt' but must be one of: $formats\n";
  413.         }
  414.  
  415.         my $output_extension =
  416.           make_extension( $rOpts->{'output-file-extension'},
  417.             $default_file_extension{ $rOpts->{'format'} }, $dot );
  418.  
  419.         my $backup_extension =
  420.           make_extension( $rOpts->{'backup-file-extension'}, 'bak', $dot );
  421.  
  422.         my $html_toc_extension =
  423.           make_extension( $rOpts->{'html-toc-extension'}, 'toc', $dot );
  424.  
  425.         my $html_src_extension =
  426.           make_extension( $rOpts->{'html-src-extension'}, 'src', $dot );
  427.  
  428.         # check for -b option;
  429.         my $in_place_modify = $rOpts->{'backup-and-modify-in-place'}
  430.           && $rOpts->{'format'} eq 'tidy' # silently ignore unless beautify mode
  431.           && @ARGV > 0;    # silently ignore if standard input;
  432.                            # this allows -b to be in a .perltidyrc file
  433.                            # without error messages when running from an editor
  434.  
  435.         # turn off -b with warnings in case of conflicts with other options
  436.         if ($in_place_modify) {
  437.             if ( $rOpts->{'standard-output'} ) {
  438.                 warn "Ignoring -b; you may not use -b and -st together\n";
  439.                 $in_place_modify = 0;
  440.             }
  441.             if ($destination_stream) {
  442.                 warn
  443. "Ignoring -b; you may not specify a destination array and -b together\n";
  444.                 $in_place_modify = 0;
  445.             }
  446.             if ($source_stream) {
  447.                 warn
  448. "Ignoring -b; you may not specify a source array and -b together\n";
  449.                 $in_place_modify = 0;
  450.             }
  451.             if ( $rOpts->{'outfile'} ) {
  452.                 warn "Ignoring -b; you may not use -b and -o together\n";
  453.                 $in_place_modify = 0;
  454.             }
  455.             if ( defined( $rOpts->{'output-path'} ) ) {
  456.                 warn "Ignoring -b; you may not use -b and -opath together\n";
  457.                 $in_place_modify = 0;
  458.             }
  459.         }
  460.  
  461.         Perl::Tidy::Formatter::check_options($rOpts);
  462.         if ( $rOpts->{'format'} eq 'html' ) {
  463.             Perl::Tidy::HtmlWriter->check_options($rOpts);
  464.         }
  465.  
  466.         # make the pattern of file extensions that we shouldn't touch
  467.         $_ = quotemeta($output_extension);
  468.         my $forbidden_file_extensions = "(($dot_pattern)(LOG|DEBUG|ERR|TEE)|$_";
  469.         if ($in_place_modify) {
  470.             $_ = quotemeta($backup_extension);
  471.             $forbidden_file_extensions .= "|$_";
  472.         }
  473.         $forbidden_file_extensions .= ')$';
  474.  
  475.         # Create a diagnostics object if requested;
  476.         # This is only useful for code development
  477.         my $diagnostics_object = undef;
  478.         if ( $rOpts->{'DIAGNOSTICS'} ) {
  479.             $diagnostics_object = Perl::Tidy::Diagnostics->new();
  480.         }
  481.  
  482.         # no filenames should be given if input is from an array
  483.         if ($source_stream) {
  484.             if ( @ARGV > 0 ) {
  485.                 die
  486. "You may not specify any filenames when a source array is given\n";
  487.             }
  488.  
  489.             # we'll stuff the source array into ARGV
  490.             unshift ( @ARGV, $source_stream );
  491.         }
  492.  
  493.         # use stdin by default if no source array and no args
  494.         else {
  495.             unshift ( @ARGV, '-' ) unless @ARGV;
  496.         }
  497.  
  498.         # loop to process all files in argument list
  499.         my $number_of_files = @ARGV;
  500.         my $formatter       = undef;
  501.         $tokenizer = undef;
  502.         while ( $input_file = shift @ARGV ) {
  503.             my $fileroot;
  504.             my $input_file_permissions;
  505.  
  506.             #---------------------------------------------------------------
  507.             # determine the input file name
  508.             #---------------------------------------------------------------
  509.             if ($source_stream) {
  510.                 $fileroot = "perltidy";
  511.             }
  512.             elsif ( $input_file eq '-' ) {    # '-' indicates input from STDIN
  513.                 $fileroot = "perltidy";   # root name to use for .ERR, .LOG, etc
  514.                 $in_place_modify = 0;
  515.             }
  516.             else {
  517.                 $fileroot = $input_file;
  518.                 unless ( -e $input_file ) {
  519.  
  520.                     # file doesn't exist - check for a file glob
  521.                     if ( $input_file =~ /([\?\*\[\{])/ ) {
  522.  
  523.                         # Windows shell may not remove quotes, so do it
  524.                         my $input_file = $input_file;
  525.                         if ( $input_file =~ /^\'(.+)\'$/ ) { $input_file = $1 }
  526.                         if ( $input_file =~ /^\"(.+)\"$/ ) { $input_file = $1 }
  527.                         my $pattern = fileglob_to_re($input_file);
  528.                         eval "/$pattern/";
  529.                         if ( !$@ && opendir( DIR, './' ) ) {
  530.                             my @files =
  531.                               grep { /$pattern/ && !-d $_ } readdir(DIR);
  532.                             closedir(DIR);
  533.                             if (@files) {
  534.                                 unshift @ARGV, @files;
  535.                                 next;
  536.                             }
  537.                         }
  538.                     }
  539.                     print "skipping: '$input_file': no matches found\n";
  540.                     next;
  541.                 }
  542.  
  543.                 unless ( -f $input_file ) {
  544.                     print "skipping: $input_file: not a regular file\n";
  545.                     next;
  546.                 }
  547.  
  548.                 unless ( ( -T $input_file ) || $rOpts->{'force-read-binary'} ) {
  549.                     print
  550. "skipping file: $input_file: Non-text (override with -f)\n";
  551.                     next;
  552.                 }
  553.  
  554.                 # we should have a valid filename now
  555.                 $fileroot               = $input_file;
  556.                 $input_file_permissions = ( stat $input_file )[2] & 07777;
  557.  
  558.                 if ( $^O eq 'VMS' ) {
  559.                     ( $fileroot, $dot ) = check_vms_filename($fileroot);
  560.                 }
  561.  
  562.                 # add option to change path here
  563.                 if ( defined( $rOpts->{'output-path'} ) ) {
  564.  
  565.                     my ( $base, $old_path ) = fileparse($fileroot);
  566.                     my $new_path = $rOpts->{'output-path'};
  567.                     unless ( -d $new_path ) {
  568.                         unless ( mkdir $new_path, 0777 ) {
  569.                             die "unable to create directory $new_path: $!\n";
  570.                         }
  571.                     }
  572.                     my $path = $new_path;
  573.                     $fileroot = catfile( $path, $base );
  574.                     unless ($fileroot) {
  575.                         die <<EOM;
  576. ------------------------------------------------------------------------
  577. Problem combining $new_path and $base to make a filename; check -opath
  578. ------------------------------------------------------------------------
  579. EOM
  580.                     }
  581.                 }
  582.             }
  583.  
  584.             # Skip files with same extension as the output files because
  585.             # this can lead to a messy situation with files like
  586.             # script.tdy.tdy.tdy ... or worse problems ...  when you
  587.             # rerun perltidy over and over with wildcard input.
  588.             if (
  589.                 !$source_stream
  590.                 && (   $input_file =~ /$forbidden_file_extensions/
  591.                     || $input_file eq 'DIAGNOSTICS' )
  592.               )
  593.             {
  594.                 print "skipping file: $input_file: wrong extension\n";
  595.                 next;
  596.             }
  597.  
  598.             # the 'source_object' supplies a method to read the input file
  599.             my $source_object =
  600.               Perl::Tidy::LineSource->new( $input_file, $rOpts,
  601.                 $rpending_logfile_message );
  602.             next unless ($source_object);
  603.  
  604.             # register this file name with the Diagnostics package
  605.             $diagnostics_object->set_input_file($input_file)
  606.               if $diagnostics_object;
  607.  
  608.             #---------------------------------------------------------------
  609.             # determine the output file name
  610.             #---------------------------------------------------------------
  611.             my $output_file = undef;
  612.             my $actual_output_extension;
  613.  
  614.             if ( $rOpts->{'outfile'} ) {
  615.  
  616.                 if ( $number_of_files <= 1 ) {
  617.  
  618.                     if ( $rOpts->{'standard-output'} ) {
  619.                         die "You may not use -o and -st together\n";
  620.                     }
  621.                     elsif ($destination_stream) {
  622.                         die
  623. "You may not specify a destination array and -o together\n";
  624.                     }
  625.                     elsif ( defined( $rOpts->{'output-path'} ) ) {
  626.                         die "You may not specify -o and -opath together\n";
  627.                     }
  628.                     elsif ( defined( $rOpts->{'output-file-extension'} ) ) {
  629.                         die "You may not specify -o and -oext together\n";
  630.                     }
  631.                     $output_file = $rOpts->{outfile};
  632.  
  633.                     # make sure user gives a file name after -o
  634.                     if ( $output_file =~ /^-/ ) {
  635.                         die "You must specify a valid filename after -o\n";
  636.                     }
  637.  
  638.                     # do not overwrite input file with -o
  639.                     if ( defined($input_file_permissions)
  640.                         && ( $output_file eq $input_file ) )
  641.                     {
  642.                         die
  643.                           "Use 'perltidy -b $input_file' to modify in-place\n";
  644.                     }
  645.                 }
  646.                 else {
  647.                     die "You may not use -o with more than one input file\n";
  648.                 }
  649.             }
  650.             elsif ( $rOpts->{'standard-output'} ) {
  651.                 if ($destination_stream) {
  652.                     die
  653. "You may not specify a destination array and -st together\n";
  654.                 }
  655.                 $output_file = '-';
  656.  
  657.                 if ( $number_of_files <= 1 ) {
  658.                 }
  659.                 else {
  660.                     die "You may not use -st with more than one input file\n";
  661.                 }
  662.             }
  663.             elsif ($destination_stream) {
  664.                 $output_file = $destination_stream;
  665.             }
  666.             elsif ($source_stream) {  # source but no destination goes to stdout
  667.                 $output_file = '-';
  668.             }
  669.             elsif ( $input_file eq '-' ) {
  670.                 $output_file = '-';
  671.             }
  672.             else {
  673.                 if ($in_place_modify) {
  674.                     $output_file = IO::File->new_tmpfile()
  675.                       or die "cannot open temp file for -b option: $!\n";
  676.                 }
  677.                 else {
  678.                     $actual_output_extension = $output_extension;
  679.                     $output_file             = $fileroot . $output_extension;
  680.                 }
  681.             }
  682.  
  683.             # the 'sink_object' knows how to write the output file
  684.             my $tee_file    = $fileroot . $dot . "TEE";
  685.             my $sink_object =
  686.               Perl::Tidy::LineSink->new( $output_file, $tee_file, $rOpts,
  687.                 $rpending_logfile_message );
  688.  
  689.             #---------------------------------------------------------------
  690.             # initialize the error logger
  691.             #---------------------------------------------------------------
  692.             my $warning_file = $fileroot . $dot . "ERR";
  693.             if ($errorfile_stream) { $warning_file = $errorfile_stream }
  694.             my $log_file = $fileroot . $dot . "LOG";
  695.             if ($logfile_stream) { $log_file = $logfile_stream }
  696.  
  697.             my $logger_object =
  698.               Perl::Tidy::Logger->new( $rOpts, $log_file, $warning_file,
  699.                 $saw_extrude );
  700.             write_logfile_header(
  701.                 $rOpts,        $logger_object, $config_file,
  702.                 $rraw_options, $Windows_type
  703.             );
  704.             if ($$rpending_logfile_message) {
  705.                 $logger_object->write_logfile_entry($$rpending_logfile_message);
  706.             }
  707.             if ($$rpending_complaint) {
  708.                 $logger_object->complain($$rpending_complaint);
  709.             }
  710.  
  711.             #---------------------------------------------------------------
  712.             # initialize the debug object, if any
  713.             #---------------------------------------------------------------
  714.             my $debugger_object = undef;
  715.             if ( $rOpts->{DEBUG} ) {
  716.                 $debugger_object =
  717.                   Perl::Tidy::Debugger->new( $fileroot . $dot . "DEBUG" );
  718.             }
  719.  
  720.             #---------------------------------------------------------------
  721.             # create a formatter for this file : html writer or pretty printer
  722.             #---------------------------------------------------------------
  723.  
  724.             # we have to delete any old formatter because, for safety,
  725.             # the formatter will check to see that there is only one.
  726.             $formatter = undef;
  727.  
  728.             if ($user_formatter) {
  729.                 $formatter = $user_formatter;
  730.             }
  731.             elsif ( $rOpts->{'format'} eq 'html' ) {
  732.                 $formatter =
  733.                   Perl::Tidy::HtmlWriter->new( $fileroot, $output_file,
  734.                     $actual_output_extension, $html_toc_extension,
  735.                     $html_src_extension );
  736.             }
  737.             elsif ( $rOpts->{'format'} eq 'tidy' ) {
  738.                 $formatter = Perl::Tidy::Formatter->new(
  739.                     logger_object      => $logger_object,
  740.                     diagnostics_object => $diagnostics_object,
  741.                     sink_object        => $sink_object,
  742.                 );
  743.             }
  744.             else {
  745.                 die "I don't know how to do -format=$rOpts->{'format'}\n";
  746.             }
  747.  
  748.             unless ($formatter) {
  749.                 die "Unable to continue with $rOpts->{'format'} formatting\n";
  750.             }
  751.  
  752.             #---------------------------------------------------------------
  753.             # create the tokenizer for this file
  754.             #---------------------------------------------------------------
  755.             $tokenizer = undef;                     # must destroy old tokenizer
  756.             $tokenizer = Perl::Tidy::Tokenizer->new(
  757.                 source_object       => $source_object,
  758.                 logger_object       => $logger_object,
  759.                 debugger_object     => $debugger_object,
  760.                 diagnostics_object  => $diagnostics_object,
  761.                 starting_level      => $rOpts->{'starting-indentation-level'},
  762.                 tabs                => $rOpts->{'tabs'},
  763.                 indent_columns      => $rOpts->{'indent-columns'},
  764.                 look_for_hash_bang  => $rOpts->{'look-for-hash-bang'},
  765.                 look_for_autoloader => $rOpts->{'look-for-autoloader'},
  766.                 look_for_selfloader => $rOpts->{'look-for-selfloader'},
  767.                 trim_qw             => $rOpts->{'trim-qw'},
  768.             );
  769.  
  770.             #---------------------------------------------------------------
  771.             # now we can do it
  772.             #---------------------------------------------------------------
  773.             process_this_file( $tokenizer, $formatter );
  774.  
  775.             #---------------------------------------------------------------
  776.             # close the input source and report errors
  777.             #---------------------------------------------------------------
  778.             $source_object->close_input_file();
  779.  
  780.             # get file names to use for syntax check
  781.             my $ifname = $source_object->get_input_file_copy_name();
  782.             my $ofname = $sink_object->get_output_file_copy();
  783.  
  784.             #---------------------------------------------------------------
  785.             # handle the -b option (backup and modify in-place)
  786.             #---------------------------------------------------------------
  787.             if ($in_place_modify) {
  788.                 unless ( -f $input_file ) {
  789.  
  790.                     # oh, oh, no real file to backup ..
  791.                     # shouldn't happen because of numerous preliminary checks
  792.                     die print
  793. "problem with -b backing up input file '$input_file': not a file\n";
  794.                 }
  795.                 my $backup_name = $input_file . $backup_extension;
  796.                 if ( -f $backup_name ) {
  797.                     unlink($backup_name)
  798.                       or die
  799. "unable to remove previous '$backup_name' for -b option; check permissions: $!\n";
  800.                 }
  801.                 rename( $input_file, $backup_name )
  802.                   or die
  803. "problem renaming $input_file to $backup_name for -b option: $!\n";
  804.                 $ifname = $backup_name;
  805.  
  806.                 seek( $output_file, 0, 0 )
  807.                   or die "unable to rewind tmp file for -b option: $!\n";
  808.  
  809.                 my $fout = IO::File->new("> $input_file")
  810.                   or die
  811. "problem opening $input_file for write for -b option; check directory permissions: $!\n";
  812.                 my $line;
  813.                 while ( $line = $output_file->getline() ) {
  814.                     $fout->print($line);
  815.                 }
  816.                 $fout->close();
  817.                 $output_file = $input_file;
  818.                 $ofname      = $input_file;
  819.             }
  820.  
  821.             #---------------------------------------------------------------
  822.             # clean up and report errors
  823.             #---------------------------------------------------------------
  824.             $sink_object->close_output_file()    if $sink_object;
  825.             $debugger_object->close_debug_file() if $debugger_object;
  826.  
  827.             my $infile_syntax_ok = 0;    # -1 no  0=don't know   1 yes
  828.             if ($output_file) {
  829.  
  830.                 if ($input_file_permissions) {
  831.  
  832.                     # give output script same permissions as input script, but
  833.                     # make it user-writable or else we can't run perltidy again.
  834.                     # Thus we retain whatever executable flags were set.
  835.                     if ( $rOpts->{'format'} eq 'tidy' ) {
  836.                         chmod( $input_file_permissions | 0600, $output_file );
  837.                     }
  838.  
  839.                     # else use default permissions for html and any other format
  840.  
  841.                 }
  842.                 if ( $logger_object && $rOpts->{'check-syntax'} ) {
  843.                     $infile_syntax_ok =
  844.                       check_syntax( $ifname, $ofname, $logger_object, $rOpts );
  845.                 }
  846.             }
  847.  
  848.             $logger_object->finish( $infile_syntax_ok, $formatter )
  849.               if $logger_object;
  850.  
  851.         }    # end of loop to process all files
  852.  
  853.     }    # end of main program
  854. }
  855.  
  856. sub fileglob_to_re {
  857.  
  858.     # modified (corrected) from version in find2perl
  859.     my $x = shift;
  860.     $x =~ s#([./^\$()])#\\$1#g;    # escape special characters
  861.     $x =~ s#\*#.*#g;               # '*' -> '.*'
  862.     $x =~ s#\?#.#g;                # '?' -> '.'
  863.     "^$x\\z";                      # match whole word
  864. }
  865.  
  866. sub make_extension {
  867.  
  868.     # Make a file extension, including any leading '.' if necessary
  869.     # The '.' may actually be an '_' under VMS
  870.     my ( $extension, $default, $dot ) = @_;
  871.  
  872.     # Use the default if none specified
  873.     $extension = $default unless ($extension);
  874.  
  875.     # Only extensions with these leading characters get a '.'
  876.     # This rule gives the user some freedom
  877.     if ( $extension =~ /^[a-zA-Z0-9]/ ) {
  878.         $extension = $dot . $extension;
  879.     }
  880.     return $extension;
  881. }
  882.  
  883. sub write_logfile_header {
  884.     my ( $rOpts, $logger_object, $config_file, $rraw_options, $Windows_type ) =
  885.       @_;
  886.     $logger_object->write_logfile_entry(
  887. "perltidy version $VERSION log file on a $^O system, OLD_PERL_VERSION=$]\n"
  888.     );
  889.     if ($Windows_type) {
  890.         $logger_object->write_logfile_entry("Windows type is $Windows_type\n");
  891.     }
  892.     my $options_string = join ( ' ', @$rraw_options );
  893.  
  894.     if ($config_file) {
  895.         $logger_object->write_logfile_entry(
  896.             "Found Configuration File >>> $config_file \n");
  897.     }
  898.     $logger_object->write_logfile_entry(
  899.         "Configuration and command line parameters for this run:\n");
  900.     $logger_object->write_logfile_entry("$options_string\n");
  901.  
  902.     if ( $rOpts->{'DEBUG'} || $rOpts->{'show-options'} ) {
  903.         $rOpts->{'logfile'} = 1;    # force logfile to be saved
  904.         $logger_object->write_logfile_entry(
  905.             "Final parameter set for this run\n");
  906.         $logger_object->write_logfile_entry(
  907.             "------------------------------------\n");
  908.  
  909.         foreach ( keys %{$rOpts} ) {
  910.             $logger_object->write_logfile_entry( '--' . "$_=$rOpts->{$_}\n" );
  911.         }
  912.         $logger_object->write_logfile_entry(
  913.             "------------------------------------\n");
  914.     }
  915.     $logger_object->write_logfile_entry(
  916.         "To find error messages search for 'WARNING' with your editor\n");
  917. }
  918.  
  919. sub process_command_line {
  920.  
  921.     my ( $perltidyrc_stream, $is_Windows, $Windows_type, $rpending_complaint ) =
  922.       @_;
  923.  
  924.     use Getopt::Long;
  925.  
  926.     ######################################################################
  927.     # Note: a few options are not documented in the man page and usage
  928.     # message. This is because these are experimental or debug options and
  929.     # may or may not be retained in future versions.
  930.     #
  931.     # Here are the undocumented flags as far as I know.  Any of them
  932.     # may disappear at any time.  They are mainly for fine-tuning
  933.     # and debugging.
  934.     #
  935.     # fll --> fuzzy-line-length           # a trivial parameter which gets
  936.     #                                       turned off for the extrude option
  937.     #                                       which is mainly for debugging
  938.     # chk --> check-multiline-quotes      # check for old bug; to be deleted
  939.     # scl --> short-concatenation-item-length   # helps break at '.'
  940.     # recombine                           # for debugging line breaks
  941.     # I   --> DIAGNOSTICS                 # for debugging
  942.     ######################################################################
  943.  
  944.     # here is a summary of the Getopt codes:
  945.     # <none> does not take an argument
  946.     # =s takes a mandatory string
  947.     # :s takes an optional string  (DO NOT USE - filenames will get eaten up)
  948.     # =i takes a mandatory integer
  949.     # :i takes an optional integer (NOT RECOMMENDED - can cause trouble)
  950.     # ! does not take an argument and may be negated
  951.     #  i.e., -foo and -nofoo are allowed
  952.     # a double dash signals the end of the options list
  953.     #
  954.     #---------------------------------------------------------------
  955.     # Define the option string passed to GetOptions.
  956.     #---------------------------------------------------------------
  957.  
  958.     my @option_string = ();
  959.     my %expansion     = ();
  960.     my $rexpansion    = \%expansion;
  961.  
  962.     #  These options are parsed directly by perltidy:
  963.     #    help h
  964.     #    version v
  965.     #  However, they are included in the option set so that they will
  966.     #  be seen in the options dump.
  967.  
  968.     # These long option names have no abbreviations or are treated specially
  969.     @option_string = qw(
  970.       html!
  971.       noprofile
  972.       npro
  973.       recombine!
  974.     );
  975.  
  976.     # routine to install and check options
  977.     my $add_option = sub {
  978.         my ( $long_name, $short_name, $flag ) = @_;
  979.         push @option_string, $long_name . $flag;
  980.         if ($short_name) {
  981.             if ( $expansion{$short_name} ) {
  982.                 my $existing_name = $expansion{$short_name}[0];
  983.                 die
  984. "redefining abbreviation $short_name for $long_name; already used for $existing_name\n";
  985.             }
  986.             $expansion{$short_name} = [$long_name];
  987.             if ( $flag eq '!' ) {
  988.                 my $nshort_name = 'n' . $short_name;
  989.                 my $nolong_name = 'no' . $long_name;
  990.                 if ( $expansion{$nshort_name} ) {
  991.                     my $existing_name = $expansion{$nshort_name}[0];
  992.                     die
  993. "attempting to redefine abbreviation $nshort_name for $nolong_name; already used for $existing_name\n";
  994.                 }
  995.                 $expansion{$nshort_name} = [$nolong_name];
  996.             }
  997.         }
  998.     };
  999.  
  1000.     # Install long option names which have a simple abbreviation.
  1001.     # Options with code '!' get standard negation ('no' for long names,
  1002.     # 'n' for abbreviations)
  1003.     $add_option->( 'DEBUG',                                     'D',     '!' );
  1004.     $add_option->( 'DIAGNOSTICS',                               'I',     '!' );
  1005.     $add_option->( 'add-newlines',                              'anl',   '!' );
  1006.     $add_option->( 'add-semicolons',                            'asc',   '!' );
  1007.     $add_option->( 'add-whitespace',                            'aws',   '!' );
  1008.     $add_option->( 'backup-and-modify-in-place',                'b',     '!' );
  1009.     $add_option->( 'backup-file-extension',                     'bext',  '=s' );
  1010.     $add_option->( 'blanks-before-blocks',                      'bbb',   '!' );
  1011.     $add_option->( 'blanks-before-comments',                    'bbc',   '!' );
  1012.     $add_option->( 'blanks-before-subs',                        'bbs',   '!' );
  1013.     $add_option->( 'block-brace-tightness',                     'bbt',   '=i' );
  1014.     $add_option->( 'block-brace-vertical-tightness',            'bbvt',  '=i' );
  1015.     $add_option->( 'block-brace-vertical-tightness-list',       'bbvtl', '=s' );
  1016.     $add_option->( 'brace-left-and-indent',                     'bli',   '!' );
  1017.     $add_option->( 'brace-left-and-indent-list',                'blil',  '=s' );
  1018.     $add_option->( 'brace-tightness',                           'bt',    '=i' );
  1019.     $add_option->( 'brace-vertical-tightness',                  'bvt',   '=i' );
  1020.     $add_option->( 'brace-vertical-tightness-closing',          'bvtc',  '=i' );
  1021.     $add_option->( 'break-at-old-comma-breakpoints',            'boc',   '!' );
  1022.     $add_option->( 'break-at-old-keyword-breakpoints',          'bok',   '!' );
  1023.     $add_option->( 'break-at-old-logical-breakpoints',          'bol',   '!' );
  1024.     $add_option->( 'break-at-old-trinary-breakpoints',          'bot',   '!' );
  1025.     $add_option->( 'check-multiline-quotes',                    'chk',   '!' );
  1026.     $add_option->( 'check-syntax',                              'syn',   '!' );
  1027.     $add_option->( 'closing-side-comment-else-flag',            'csce',  '=i' );
  1028.     $add_option->( 'closing-side-comment-interval',             'csci',  '=i' );
  1029.     $add_option->( 'closing-side-comment-list',                 'cscl',  '=s' );
  1030.     $add_option->( 'closing-side-comment-maximum-text',         'csct',  '=i' );
  1031.     $add_option->( 'closing-side-comment-prefix',               'cscp',  '=s' );
  1032.     $add_option->( 'closing-side-comment-warnings',             'cscw',  '!' );
  1033.     $add_option->( 'closing-side-comments',                     'csc',   '!' );
  1034.     $add_option->( 'continuation-indentation',                  'ci',    '=i' );
  1035.     $add_option->( 'comma-arrow-breakpoints',                   'cab',   '=i' );
  1036.     $add_option->( 'cuddled-else',                              'ce',    '!' );
  1037.     $add_option->( 'delete-block-comments',                     'dbc',   '!' );
  1038.     $add_option->( 'delete-closing-side-comments',              'dcsc',  '!' );
  1039.     $add_option->( 'delete-old-newlines',                       'dnl',   '!' );
  1040.     $add_option->( 'delete-old-whitespace',                     'dws',   '!' );
  1041.     $add_option->( 'delete-pod',                                'dp',    '!' );
  1042.     $add_option->( 'delete-semicolons',                         'dsm',   '!' );
  1043.     $add_option->( 'delete-side-comments',                      'dsc',   '!' );
  1044.     $add_option->( 'dump-defaults',                             'ddf',   '!' );
  1045.     $add_option->( 'dump-long-names',                           'dln',   '!' );
  1046.     $add_option->( 'dump-options',                              'dop',   '!' );
  1047.     $add_option->( 'dump-profile',                              'dpro',  '!' );
  1048.     $add_option->( 'dump-short-names',                          'dsn',   '!' );
  1049.     $add_option->( 'dump-token-types',                          'dtt',   '!' );
  1050.     $add_option->( 'dump-want-left-space',                      'dwls',  '!' );
  1051.     $add_option->( 'dump-want-right-space',                     'dwrs',  '!' );
  1052.     $add_option->( 'entab-leading-whitespace',                  'et',    '=i' );
  1053.     $add_option->( 'force-read-binary',                         'f',     '!' );
  1054.     $add_option->( 'format',                                    'fmt',   '=s' );
  1055.     $add_option->( 'fuzzy-line-length',                         'fll',   '!' );
  1056.     $add_option->( 'hanging-side-comments',                     'hsc',   '!' );
  1057.     $add_option->( 'help',                                      'h',     '' );
  1058.     $add_option->( 'ignore-old-line-breaks',                    'iob',   '!' );
  1059.     $add_option->( 'indent-block-comments',                     'ibc',   '!' );
  1060.     $add_option->( 'indent-closing-brace',                      'icb',   '!' );
  1061.     $add_option->( 'indent-closing-paren',                      'icp',   '!' );
  1062.     $add_option->( 'indent-columns',                            'i',     '=i' );
  1063.     $add_option->( 'indent-spaced-block-comments',              'isbc',  '!' );
  1064.     $add_option->( 'line-up-parentheses',                       'lp',    '!' );
  1065.     $add_option->( 'logfile',                                   'log',   '!' );
  1066.     $add_option->( 'logfile-gap',                               'g',     ':i' );
  1067.     $add_option->( 'long-block-line-count',                     'lbl',   '=i' );
  1068.     $add_option->( 'look-for-autoloader',                       'lal',   '!' );
  1069.     $add_option->( 'look-for-hash-bang',                        'x',     '!' );
  1070.     $add_option->( 'look-for-selfloader',                       'lsl',   '!' );
  1071.     $add_option->( 'maximum-consecutive-blank-lines',           'mbl',   '=i' );
  1072.     $add_option->( 'maximum-fields-per-table',                  'mft',   '=i' );
  1073.     $add_option->( 'maximum-line-length',                       'l',     '=i' );
  1074.     $add_option->( 'minimum-space-to-comment',                  'msc',   '=i' );
  1075.     $add_option->( 'nowant-left-space',                         'nwls',  '=s' );
  1076.     $add_option->( 'nowant-right-space',                        'nwrs',  '=s' );
  1077.     $add_option->( 'opening-brace-always-on-right',             'bar',   '' );
  1078.     $add_option->( 'opening-brace-on-new-line',                 'bl',    '!' );
  1079.     $add_option->( 'opening-sub-brace-on-new-line',             'sbl',   '!' );
  1080.     $add_option->( 'outdent-keyword-list',                      'okwl',  '=s' );
  1081.     $add_option->( 'outdent-keywords',                          'okw',   '!' );
  1082.     $add_option->( 'outdent-labels',                            'ola',   '!' );
  1083.     $add_option->( 'outdent-long-comments',                     'olc',   '!' );
  1084.     $add_option->( 'outdent-long-quotes',                       'olq',   '!' );
  1085.     $add_option->( 'outdent-static-block-comments',             'osbc',  '!' );
  1086.     $add_option->( 'outfile',                                   'o',     '=s' );
  1087.     $add_option->( 'output-file-extension',                     'oext',  '=s' );
  1088.     $add_option->( 'output-path',                               'opath', '=s' );
  1089.     $add_option->( 'paren-tightness',                           'pt',    '=i' );
  1090.     $add_option->( 'paren-vertical-tightness',                  'pvt',   '=i' );
  1091.     $add_option->( 'paren-vertical-tightness-closing',          'pvtc',  '=i' );
  1092.     $add_option->( 'pass-version-line',                         'pvl',   '!' );
  1093.     $add_option->( 'perl-syntax-check-flags',                   'pscf',  '=s' );
  1094.     $add_option->( 'profile',                                   'pro',   '=s' );
  1095.     $add_option->( 'quiet',                                     'q',     '!' );
  1096.     $add_option->( 'short-concatenation-item-length',           'scl',   '=i' );
  1097.     $add_option->( 'show-options',                              'opt',   '!' );
  1098.     $add_option->( 'space-for-semicolon',                       'sfs',   '!' );
  1099.     $add_option->( 'space-terminal-semicolon',                  'sts',   '!' );
  1100.     $add_option->( 'square-bracket-tightness',                  'sbt',   '=i' );
  1101.     $add_option->( 'square-bracket-vertical-tightness',         'sbvt',  '=i' );
  1102.     $add_option->( 'square-bracket-vertical-tightness-closing', 'sbvtc', '=i' );
  1103.     $add_option->( 'standard-error-output',                     'se',    '!' );
  1104.     $add_option->( 'standard-output',                           'st',    '!' );
  1105.     $add_option->( 'starting-indentation-level',                'sil',   '=i' );
  1106.     $add_option->( 'static-block-comment-prefix',               'sbcp',  '=s' );
  1107.     $add_option->( 'static-block-comments',                     'sbc',   '!' );
  1108.     $add_option->( 'static-side-comment-prefix',                'sscp',  '=s' );
  1109.     $add_option->( 'static-side-comments',                      'ssc',   '!' );
  1110.     $add_option->( 'swallow-optional-blank-lines',              'sob',   '!' );
  1111.     $add_option->( 'tabs',                                      't',     '!' );
  1112.     $add_option->( 'tee-block-comments',                        'tbc',   '!' );
  1113.     $add_option->( 'tee-pod',                                   'tp',    '!' );
  1114.     $add_option->( 'tee-side-comments',                         'tsc',   '!' );
  1115.     $add_option->( 'trim-qw',                                   'tqw',   '!' );
  1116.     $add_option->( 'version',                                   'v',     '' );
  1117.     $add_option->( 'vertical-tightness',                        'vt',    '=i' );
  1118.     $add_option->( 'vertical-tightness-closing',                'vtc',   '=i' );
  1119.     $add_option->( 'want-break-after',                          'wba',   '=s' );
  1120.     $add_option->( 'want-break-before',                         'wbb',   '=s' );
  1121.     $add_option->( 'want-left-space',                           'wls',   '=s' );
  1122.     $add_option->( 'want-right-space',                          'wrs',   '=s' );
  1123.     $add_option->( 'warning-output',                            'w',     '!' );
  1124.  
  1125.     # The Perl::Tidy::HtmlWriter will add its own options to the string
  1126.     Perl::Tidy::HtmlWriter->make_getopt_long_names( \@option_string );
  1127.  
  1128.     #---------------------------------------------------------------
  1129.     # Assign default values to the above options here, except
  1130.     # for 'outfile' and 'help'.
  1131.     # These settings should approximate the perlstyle(1) suggestions.
  1132.     #---------------------------------------------------------------
  1133.     my @defaults = qw(
  1134.       add-newlines
  1135.       add-semicolons
  1136.       add-whitespace
  1137.       blanks-before-blocks
  1138.       blanks-before-comments
  1139.       blanks-before-subs
  1140.       block-brace-tightness=0
  1141.       block-brace-vertical-tightness=0
  1142.       brace-tightness=1
  1143.       brace-vertical-tightness-closing=0
  1144.       brace-vertical-tightness=0
  1145.       break-at-old-logical-breakpoints
  1146.       break-at-old-trinary-breakpoints
  1147.       break-at-old-keyword-breakpoints
  1148.       comma-arrow-breakpoints=1
  1149.       check-syntax
  1150.       closing-side-comment-interval=6
  1151.       closing-side-comment-maximum-text=20
  1152.       closing-side-comment-else-flag=0
  1153.       continuation-indentation=2
  1154.       delete-old-newlines
  1155.       delete-semicolons
  1156.       fuzzy-line-length
  1157.       hanging-side-comments
  1158.       indent-block-comments
  1159.       indent-columns=4
  1160.       long-block-line-count=8
  1161.       look-for-autoloader
  1162.       look-for-selfloader
  1163.       maximum-consecutive-blank-lines=1
  1164.       maximum-fields-per-table=0
  1165.       maximum-line-length=80
  1166.       minimum-space-to-comment=4
  1167.       nobrace-left-and-indent
  1168.       nocuddled-else
  1169.       nodelete-old-whitespace
  1170.       nohtml
  1171.       noindent-closing-brace
  1172.       noindent-closing-paren
  1173.       nologfile
  1174.       noquiet
  1175.       noshow-options
  1176.       nostatic-side-comments
  1177.       noswallow-optional-blank-lines
  1178.       notabs
  1179.       nowarning-output
  1180.       outdent-labels
  1181.       outdent-long-quotes
  1182.       outdent-long-comments
  1183.       paren-tightness=1
  1184.       paren-vertical-tightness-closing=0
  1185.       paren-vertical-tightness=0
  1186.       pass-version-line
  1187.       recombine
  1188.       short-concatenation-item-length=8
  1189.       space-for-semicolon
  1190.       square-bracket-tightness=1
  1191.       square-bracket-vertical-tightness-closing=0
  1192.       square-bracket-vertical-tightness=0
  1193.       static-block-comments
  1194.       trim-qw
  1195.       format=tidy
  1196.       backup-file-extension=bak
  1197.  
  1198.       pod2html
  1199.       html-table-of-contents
  1200.     );
  1201.  
  1202.     push @defaults, "perl-syntax-check-flags=-c -T";
  1203.  
  1204.     #---------------------------------------------------------------
  1205.     # set the defaults by passing the above list through GetOptions
  1206.     #---------------------------------------------------------------
  1207.     my %Opts = ();
  1208.     {
  1209.         local @ARGV;
  1210.         my $i;
  1211.  
  1212.         for $i (@defaults) { push @ARGV, "--" . $i }
  1213.  
  1214.         if ( !GetOptions( \%Opts, @option_string ) ) {
  1215.             die "Programming Bug: error in setting default options";
  1216.         }
  1217.     }
  1218.  
  1219.     #---------------------------------------------------------------
  1220.     # Define abbreviations which will be expanded into the above primitives.
  1221.     # These may be defined recursively.
  1222.     #---------------------------------------------------------------
  1223.     %expansion = (
  1224.         %expansion,
  1225.         'freeze-newlines'    => [qw(noadd-newlines nodelete-old-newlines)],
  1226.         'fnl'                => [qw(freeze-newlines)],
  1227.         'freeze-whitespace'  => [qw(noadd-whitespace nodelete-old-whitespace)],
  1228.         'fws'                => [qw(freeze-whitespace)],
  1229.         'indent-only'        => [qw(freeze-newlines freeze-whitespace)],
  1230.         'outdent-long-lines' => [qw(outdent-long-quotes outdent-long-comments)],
  1231.         'nooutdent-long-lines' =>
  1232.           [qw(nooutdent-long-quotes nooutdent-long-comments)],
  1233.         'noll'                => [qw(nooutdent-long-lines)],
  1234.         'io'                  => [qw(indent-only)],
  1235.         'delete-all-comments' =>
  1236.           [qw(delete-block-comments delete-side-comments delete-pod)],
  1237.         'nodelete-all-comments' =>
  1238.           [qw(nodelete-block-comments nodelete-side-comments nodelete-pod)],
  1239.         'dac'              => [qw(delete-all-comments)],
  1240.         'ndac'             => [qw(nodelete-all-comments)],
  1241.         'gnu'              => [qw(gnu-style)],
  1242.         'tee-all-comments' =>
  1243.           [qw(tee-block-comments tee-side-comments tee-pod)],
  1244.         'notee-all-comments' =>
  1245.           [qw(notee-block-comments notee-side-comments notee-pod)],
  1246.         'tac'   => [qw(tee-all-comments)],
  1247.         'ntac'  => [qw(notee-all-comments)],
  1248.         'html'  => [qw(format=html)],
  1249.         'nhtml' => [qw(format=tidy)],
  1250.         'tidy'  => [qw(format=tidy)],
  1251.  
  1252.         'break-after-comma-arrows'   => [qw(cab=0)],
  1253.         'nobreak-after-comma-arrows' => [qw(cab=1)],
  1254.         'baa'                        => [qw(cab=0)],
  1255.         'nbaa'                       => [qw(cab=1)],
  1256.  
  1257.         'vt=0' => [qw(pvt=0 bvt=0 sbvt=0)],
  1258.         'vt=1' => [qw(pvt=1 bvt=1 sbvt=1)],
  1259.         'vt=2' => [qw(pvt=2 bvt=2 sbvt=2)],
  1260.  
  1261.         'vertical-tightness=0' => [qw(pvt=0 bvt=0 sbvt=0)],
  1262.         'vertical-tightness=1' => [qw(pvt=1 bvt=1 sbvt=1)],
  1263.         'vertical-tightness=2' => [qw(pvt=2 bvt=2 sbvt=2)],
  1264.  
  1265.         'vtc=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
  1266.         'vtc=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
  1267.         'vtc=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
  1268.  
  1269.         'vertical-tightness-closing=0' => [qw(pvtc=0 bvtc=0 sbvtc=0)],
  1270.         'vertical-tightness-closing=1' => [qw(pvtc=1 bvtc=1 sbvtc=1)],
  1271.         'vertical-tightness-closing=2' => [qw(pvtc=2 bvtc=2 sbvtc=2)],
  1272.  
  1273.         # 'mangle' originally deleted pod and comments, but to keep it
  1274.         # reversible, it no longer does.  But if you really want to
  1275.         # delete them, just use:
  1276.         #   -mangle -dac
  1277.  
  1278.         # An interesting use for 'mangle' is to do this:
  1279.         #    perltidy -mangle myfile.pl -st | perltidy -o myfile.pl.new
  1280.         # which will form as many one-line blocks as possible
  1281.  
  1282.         'mangle' => [
  1283.             qw(
  1284.               check-syntax
  1285.               delete-old-newlines
  1286.               delete-old-whitespace
  1287.               delete-semicolons
  1288.               indent-columns=0
  1289.               maximum-consecutive-blank-lines=0
  1290.               maximum-line-length=100000
  1291.               noadd-newlines
  1292.               noadd-semicolons
  1293.               noadd-whitespace
  1294.               noblanks-before-blocks
  1295.               noblanks-before-subs
  1296.               notabs
  1297.               )
  1298.         ],
  1299.  
  1300.         # 'extrude' originally deleted pod and comments, but to keep it
  1301.         # reversible, it no longer does.  But if you really want to
  1302.         # delete them, just use
  1303.         #   extrude -dac
  1304.         #
  1305.         # An interesting use for 'extrude' is to do this:
  1306.         #    perltidy -extrude myfile.pl -st | perltidy -o myfile.pl.new
  1307.         # which will break up all one-line blocks.
  1308.  
  1309.         'extrude' => [
  1310.             qw(
  1311.               check-syntax
  1312.               ci=0
  1313.               delete-old-newlines
  1314.               delete-old-whitespace
  1315.               delete-semicolons
  1316.               indent-columns=0
  1317.               maximum-consecutive-blank-lines=0
  1318.               maximum-line-length=1
  1319.               noadd-semicolons
  1320.               noadd-whitespace
  1321.               noblanks-before-blocks
  1322.               noblanks-before-subs
  1323.               nofuzzy-line-length
  1324.               notabs
  1325.               )
  1326.         ],
  1327.  
  1328.         # this style tries to follow the GNU Coding Standards (which do
  1329.         # not really apply to perl but which are followed by some perl
  1330.         # programmers).
  1331.         'gnu-style' => [
  1332.             qw(
  1333.               lp bl noll pt=2 bt=2 sbt=2 icp
  1334.               )
  1335.         ],
  1336.  
  1337.         # Additional styles can be added here
  1338.     );
  1339.  
  1340.     Perl::Tidy::HtmlWriter->make_abbreviated_names( \%expansion );
  1341.  
  1342.     # Uncomment next line to dump all expansions for debugging:
  1343.     # dump_short_names(\%expansion);
  1344.  
  1345.     my $word;
  1346.     my @raw_options        = ();
  1347.     my $config_file        = "";
  1348.     my $saw_ignore_profile = 0;
  1349.     my $saw_extrude        = 0;
  1350.     my $saw_dump_profile   = 0;
  1351.     my $i;
  1352.  
  1353.     #---------------------------------------------------------------
  1354.     # Take a first look at the command-line parameters.  Do as many
  1355.     # immediate dumps as possible, which can avoid confusion if the
  1356.     # perltidyrc file has an error.
  1357.     #---------------------------------------------------------------
  1358.     foreach $i (@ARGV) {
  1359.  
  1360.         $i =~ s/^--/-/;
  1361.         if ( $i =~ /^-(npro|noprofile)$/ ) {
  1362.             $saw_ignore_profile = 1;
  1363.         }
  1364.  
  1365.         # note: this must come before -pro and -profile, below:
  1366.         elsif ( $i =~ /^-(dump-profile|dpro)$/ ) {
  1367.             $saw_dump_profile = 1;
  1368.         }
  1369.         elsif ( $i =~ /^-(pro|profile)=(.+)/ ) {
  1370.             if ($config_file) {
  1371.                 warn
  1372. "Only one -pro=filename allowed, using '$2' instead of '$config_file'\n";
  1373.             }
  1374.             $config_file = $2;
  1375.             unless ( -e $config_file ) {
  1376.                 warn "cannot find file given with -pro=$config_file: $!\n";
  1377.                 $config_file = "";
  1378.             }
  1379.         }
  1380.         elsif ( $i =~ /^-(pro|profile)=?$/ ) {
  1381.             die "usage: -pro=filename or --profile=filename, no spaces\n";
  1382.         }
  1383.         elsif ( $i =~ /^-extrude$/ ) {
  1384.             $saw_extrude = 1;
  1385.         }
  1386.         elsif ( $i =~ /^-(help|h|HELP|H)$/ ) {
  1387.             usage();
  1388.             exit 1;
  1389.         }
  1390.         elsif ( $i =~ /^-(version|v)$/ ) {
  1391.             show_version();
  1392.             exit 1;
  1393.         }
  1394.         elsif ( $i =~ /^-(dump-defaults|ddf)$/ ) {
  1395.             dump_defaults(@defaults);
  1396.             exit 1;
  1397.         }
  1398.         elsif ( $i =~ /^-(dump-long-names|dln)$/ ) {
  1399.             dump_long_names(@option_string);
  1400.             exit 1;
  1401.         }
  1402.         elsif ( $i =~ /^-(dump-short-names|dsn)$/ ) {
  1403.             dump_short_names( \%expansion );
  1404.             exit 1;
  1405.         }
  1406.         elsif ( $i =~ /^-(dump-token-types|dtt)$/ ) {
  1407.             Perl::Tidy::Tokenizer->dump_token_types(*STDOUT);
  1408.             exit 1;
  1409.         }
  1410.     }
  1411.  
  1412.     if ( $saw_dump_profile && $saw_ignore_profile ) {
  1413.         warn "No profile to dump because of -npro\n";
  1414.         exit 1;
  1415.     }
  1416.  
  1417.     #---------------------------------------------------------------
  1418.     # read any .perltidyrc configuration file
  1419.     #---------------------------------------------------------------
  1420.     unless ($saw_ignore_profile) {
  1421.  
  1422.         # resolve possible conflict between $perltidyrc_stream passed
  1423.         # as call parameter to perltidy and -pro=filename on command
  1424.         # line.
  1425.         if ($perltidyrc_stream) {
  1426.             if ($config_file) {
  1427.                 warn <<EOM;
  1428.  Conflict: a perltidyrc configuration file was specified both as this
  1429.  perltidy call parameter: $perltidyrc_stream 
  1430.  and with this -profile=$config_file.
  1431.  Using -profile=$config_file.
  1432. EOM
  1433.             }
  1434.             else {
  1435.                 $config_file = $perltidyrc_stream;
  1436.             }
  1437.         }
  1438.  
  1439.         # look for a config file if we don't have one yet
  1440.         my $rconfig_file_chatter;
  1441.         $$rconfig_file_chatter = "";
  1442.         $config_file           =
  1443.           find_config_file( $is_Windows, $Windows_type, $rconfig_file_chatter,
  1444.             $rpending_complaint )
  1445.           unless $config_file;
  1446.  
  1447.         # open any config file
  1448.         my $fh_config;
  1449.         if ($config_file) {
  1450.             ( $fh_config, $config_file ) =
  1451.               Perl::Tidy::streamhandle( $config_file, 'r' );
  1452.             unless ($fh_config) {
  1453.                 $$rconfig_file_chatter .=
  1454.                   "# $config_file exists but cannot be opened\n";
  1455.             }
  1456.         }
  1457.  
  1458.         if ($saw_dump_profile) {
  1459.             if ($saw_dump_profile) {
  1460.                 dump_config_file( $fh_config, $config_file,
  1461.                     $rconfig_file_chatter );
  1462.                 exit 1;
  1463.             }
  1464.         }
  1465.  
  1466.         if ($fh_config) {
  1467.  
  1468.             my $rconfig_list =
  1469.               read_config_file( $fh_config, $config_file, \%expansion );
  1470.  
  1471.             # process any .perltidyrc parameters right now so we can
  1472.             # localize errors
  1473.             if (@$rconfig_list) {
  1474.                 local @ARGV = @$rconfig_list;
  1475.  
  1476.                 expand_command_abbreviations( \%expansion, \@raw_options,
  1477.                     $config_file );
  1478.  
  1479.                 if ( !GetOptions( \%Opts, @option_string ) ) {
  1480.                     die
  1481. "Error in this config file: $config_file  \nUse -npro to ignore this file, -h for help'\n";
  1482.                 }
  1483.  
  1484.                 # Undo any options which cause premature exit.  They are not
  1485.                 # appropriate for a config file, and it could be hard to
  1486.                 # diagnose the cause of the premature exit.
  1487.                 foreach (
  1488.                     qw{
  1489.                     dump-defaults
  1490.                     dump-long-names
  1491.                     dump-options
  1492.                     dump-profile
  1493.                     dump-short-names
  1494.                     dump-token-types
  1495.                     dump-want-left-space
  1496.                     dump-want-right-space
  1497.                     help
  1498.                     stylesheet
  1499.                     version
  1500.                     }
  1501.                   )
  1502.                 {
  1503.                     if ( defined( $Opts{$_} ) ) {
  1504.                         delete $Opts{$_};
  1505.                         warn "ignoring --$_ in config file: $config_file\n";
  1506.                     }
  1507.                 }
  1508.             }
  1509.         }
  1510.     }
  1511.  
  1512.     #---------------------------------------------------------------
  1513.     # now process the command line parameters
  1514.     #---------------------------------------------------------------
  1515.     expand_command_abbreviations( \%expansion, \@raw_options, $config_file );
  1516.  
  1517.     if ( !GetOptions( \%Opts, @option_string ) ) {
  1518.         die "Error on command line; for help try 'perltidy -h'\n";
  1519.     }
  1520.  
  1521.     if ( $Opts{'dump-options'} ) {
  1522.         dump_options( \%Opts );
  1523.         exit 1;
  1524.     }
  1525.  
  1526.     #---------------------------------------------------------------
  1527.     # Now we have to handle any interactions among the options..
  1528.     #---------------------------------------------------------------
  1529.  
  1530.     # Since -vt and -vtc are really abbreviations, we cannot allow
  1531.     # any spaces around the equal sign.  The error messages would
  1532.     # be confusing without these checks:
  1533.     if ( defined $Opts{'vertical-tightness'} ) {
  1534.         die "Please enter -vt=0, -vt=1, or -vt=2 without any spaces";
  1535.     }
  1536.     if ( defined $Opts{'vertical-tightness-closing'} ) {
  1537.         die "Please enter -vtc=0, -vtc=1, or -vtc=2 without any spaces";
  1538.     }
  1539.  
  1540.     # In quiet mode, there is no log file and hence no way to report
  1541.     # results of syntax check, so don't do it.
  1542.     if ( $Opts{'quiet'} ) {
  1543.         $Opts{'check-syntax'} = 0;
  1544.     }
  1545.  
  1546.     # can't check syntax if no output
  1547.     if ( $Opts{'format'} ne 'tidy' ) {
  1548.         $Opts{'check-syntax'} = 0;
  1549.     }
  1550.  
  1551.     # Never let Windows 9x/Me systems run syntax check -- this will prevent a
  1552.     # wide variety of nasty problems on these systems, because they cannot
  1553.     # reliably run backticks.  Don't even think about changing this!
  1554.     if (   $Opts{'check-syntax'}
  1555.         && $is_Windows
  1556.         && ( !$Windows_type || $Windows_type =~ /^(9|Me)/ ) )
  1557.     {
  1558.         $Opts{'check-syntax'} = 0;
  1559.     }
  1560.  
  1561.     # It's really a bad idea to check syntax as root unless you wrote
  1562.     # the script yourself.  FIXME: not sure if this works with VMS
  1563.     unless ($is_Windows) {
  1564.  
  1565.         if ( $< == 0 && $Opts{'check-syntax'} ) {
  1566.             $Opts{'check-syntax'} = 0;
  1567.             $$rpending_complaint .=
  1568. "Syntax check deactivated for safety; you shouldn't run this as root\n";
  1569.         }
  1570.     }
  1571.  
  1572.     # see if user set a non-negative logfile-gap
  1573.     if ( defined( $Opts{'logfile-gap'} ) && $Opts{'logfile-gap'} >= 0 ) {
  1574.  
  1575.         # a zero gap will be taken as a 1
  1576.         if ( $Opts{'logfile-gap'} == 0 ) {
  1577.             $Opts{'logfile-gap'} = 1;
  1578.         }
  1579.  
  1580.         # setting a non-negative logfile gap causes logfile to be saved
  1581.         $Opts{'logfile'} = 1;
  1582.     }
  1583.  
  1584.     # not setting logfile gap, or setting it negative, causes default of 50
  1585.     else {
  1586.         $Opts{'logfile-gap'} = 50;
  1587.     }
  1588.  
  1589.     # set short-cut flag when only indentation is to be done.
  1590.     # Note that the user may or may not have already set the
  1591.     # indent-only flag.
  1592.     if (   !$Opts{'add-whitespace'}
  1593.         && !$Opts{'delete-old-whitespace'}
  1594.         && !$Opts{'add-newlines'}
  1595.         && !$Opts{'delete-old-newlines'} )
  1596.     {
  1597.         $Opts{'indent-only'} = 1;
  1598.     }
  1599.  
  1600.     # -isbc implies -ibc
  1601.     if ( $Opts{'indent-spaced-block-comments'} ) {
  1602.         $Opts{'indent-block-comments'} = 1;
  1603.     }
  1604.  
  1605.     # -bli flag implies -bl
  1606.     if ( $Opts{'brace-left-and-indent'} ) {
  1607.         $Opts{'opening-brace-on-new-line'} = 1;
  1608.     }
  1609.  
  1610.     if (   $Opts{'opening-brace-always-on-right'}
  1611.         && $Opts{'opening-brace-on-new-line'} )
  1612.     {
  1613.         warn <<EOM;
  1614.  Conflict: you specified both 'opening-brace-always-on-right' (-bar) and 
  1615.   'opening-brace-on-new-line' (-bl).  Ignoring -bl. 
  1616. EOM
  1617.         $Opts{'opening-brace-on-new-line'} = 0;
  1618.     }
  1619.  
  1620.     # it simplifies things if -bl is 0 rather than undefined
  1621.     if ( !defined( $Opts{'opening-brace-on-new-line'} ) ) {
  1622.         $Opts{'opening-brace-on-new-line'} = 0;
  1623.     }
  1624.  
  1625.     # -sbl defaults to -bl if not defined
  1626.     if ( !defined( $Opts{'opening-sub-brace-on-new-line'} ) ) {
  1627.         $Opts{'opening-sub-brace-on-new-line'} =
  1628.           $Opts{'opening-brace-on-new-line'};
  1629.     }
  1630.  
  1631.     # set shortcut flag if no blanks to be written
  1632.     unless ( $Opts{'maximum-consecutive-blank-lines'} ) {
  1633.         $Opts{'swallow-optional-blank-lines'} = 1;
  1634.     }
  1635.  
  1636.     if ( $Opts{'entab-leading-whitespace'} ) {
  1637.         if ( $Opts{'entab-leading-whitespace'} < 0 ) {
  1638.             warn "-et=n must use a positive integer; ignoring -et\n";
  1639.             $Opts{'entab-leading-whitespace'} = undef;
  1640.         }
  1641.  
  1642.         # entab leading whitespace has priority over the older 'tabs' option
  1643.         if ( $Opts{'tabs'} ) { $Opts{'tabs'} = 0; }
  1644.     }
  1645.  
  1646.     return ( \%Opts, $config_file, \@raw_options, $saw_extrude );
  1647.  
  1648. }    # end of process_command_line
  1649.  
  1650. sub expand_command_abbreviations {
  1651.  
  1652.     # go through @ARGV and expand any abbreviations
  1653.  
  1654.     my ( $rexpansion, $rraw_options, $config_file ) = @_;
  1655.     my ($word);
  1656.  
  1657.     # set a pass limit to prevent an infinite loop;
  1658.     # 10 should be plenty, but it may be increased to allow deeply
  1659.     # nested expansions.
  1660.     my $max_passes = 10;
  1661.     my @new_argv   = ();
  1662.  
  1663.     # keep looping until all expansions have been converted into actual
  1664.     # dash parameters..
  1665.     for ( my $pass_count = 0 ; $pass_count <= $max_passes ; $pass_count++ ) {
  1666.         my @new_argv     = ();
  1667.         my $abbrev_count = 0;
  1668.  
  1669.         # loop over each item in @ARGV..
  1670.         foreach $word (@ARGV) {
  1671.  
  1672.             # if it is a dash flag (instead of a file name)..
  1673.             if ( $word =~ /^-[-]?([\w\-]+)(.*)/ ) {
  1674.  
  1675.                 my $abr   = $1;
  1676.                 my $flags = $2;
  1677.  
  1678.                 # save the raw input for debug output in case of circular refs
  1679.                 if ( $pass_count == 0 ) {
  1680.                     push ( @$rraw_options, $word );
  1681.                 }
  1682.  
  1683.                 # recombine abbreviation and flag, if necessary,
  1684.                 # to allow abbreviations with arguments such as '-vt=1'
  1685.                 if ( $rexpansion->{ $abr . $flags } ) {
  1686.                     $abr   = $abr . $flags;
  1687.                     $flags = "";
  1688.                 }
  1689.  
  1690.                 # if we see this dash item in the expansion hash..
  1691.                 if ( $rexpansion->{$abr} ) {
  1692.                     $abbrev_count++;
  1693.  
  1694.                     # stuff all of the words that it expands to into the
  1695.                     # new arg list for the next pass
  1696.                     foreach my $abbrev ( @{ $rexpansion->{$abr} } ) {
  1697.                         next unless $abbrev;    # for safety; shouldn't happen
  1698.                         push ( @new_argv, '--' . $abbrev . $flags );
  1699.                     }
  1700.                 }
  1701.  
  1702.                 # not in expansion hash, must be actual long name
  1703.                 else {
  1704.                     push ( @new_argv, $word );
  1705.                 }
  1706.             }
  1707.  
  1708.             # not a dash item, so just save it for the next pass
  1709.             else {
  1710.                 push ( @new_argv, $word );
  1711.             }
  1712.         }    # end of this pass
  1713.  
  1714.         # update parameter list @ARGV to the new one
  1715.         @ARGV = @new_argv;
  1716.         last unless ( $abbrev_count > 0 );
  1717.  
  1718.         # make sure we are not in an infinite loop
  1719.         if ( $pass_count == $max_passes ) {
  1720.             print STDERR
  1721. "I'm tired. We seem to be in an infinite loop trying to expand aliases.\n";
  1722.             print STDERR "Here are the raw options\n";
  1723.             local $" = ')(';
  1724.             print STDERR "(@$rraw_options)\n";
  1725.             my $num = @new_argv;
  1726.  
  1727.             if ( $num < 50 ) {
  1728.                 print STDERR "After $max_passes passes here is ARGV\n";
  1729.                 print STDERR "(@new_argv)\n";
  1730.             }
  1731.             else {
  1732.                 print STDERR "After $max_passes passes ARGV has $num entries\n";
  1733.             }
  1734.  
  1735.             if ($config_file) {
  1736.                 die <<"DIE";
  1737. Please check your configuration file $config_file for circular-references. 
  1738. To deactivate it, use -npro.
  1739. DIE
  1740.             }
  1741.             else {
  1742.                 die <<'DIE';
  1743. Program bug - circular-references in the %expansion hash, probably due to
  1744. a recent program change.
  1745. DIE
  1746.             }
  1747.         }    # end of check for circular references
  1748.     }    # end of loop over all passes
  1749. }
  1750.  
  1751. # Debug routine -- this will dump the expansion hash
  1752. sub dump_short_names {
  1753.     my $rexpansion = shift;
  1754.     print STDOUT <<EOM;
  1755. List of short names.  This list shows how all abbreviations are
  1756. translated into other abbreviations and, eventually, into long names.
  1757. New abbreviations may be defined in a .perltidyrc file.  
  1758. For a list of all long names, use perltidy --dump-long-names (-dln).
  1759. --------------------------------------------------------------------------
  1760. EOM
  1761.     foreach my $abbrev ( sort keys %$rexpansion ) {
  1762.         my @list = @{ $$rexpansion{$abbrev} };
  1763.         print STDOUT "$abbrev --> @list\n";
  1764.     }
  1765. }
  1766.  
  1767. sub check_vms_filename {
  1768.  
  1769.     # given a valid filename (the perltidy input file)
  1770.     # create a modified filename and separator character
  1771.     # suitable for VMS.
  1772.     #
  1773.     # Contributed by Michael Cartmell
  1774.     #
  1775.     my ( $base, $path ) = fileparse( $_[0] );
  1776.  
  1777.     # remove explicit ; version
  1778.     $base =~ s/;-?\d*$//
  1779.  
  1780.       # remove explicit . version ie two dots in filename NB ^ escapes a dot
  1781.       or $base =~ s/(          # begin capture $1
  1782.                   (?:^|[^^])\. # match a dot not preceded by a caret
  1783.                   (?:          # followed by nothing
  1784.                     |          # or
  1785.                     .*[^^]     # anything ending in a non caret
  1786.                   )
  1787.                 )              # end capture $1
  1788.                 \.-?\d*$       # match . version number
  1789.               /$1/x;
  1790.  
  1791.     # normalise filename, if there are no unescaped dots then append one
  1792.     $base .= '.' unless $base =~ /(?:^|[^^])\./;
  1793.  
  1794.     # if we don't already have an extension then we just append the extention
  1795.     my $separator = ( $base =~ /\.$/ ) ? "" : "_";
  1796.     return ( $path . $base, $separator );
  1797. }
  1798.  
  1799. sub Win_OS_Type {
  1800.  
  1801.     # Returns a string that determines what MS OS we are on.
  1802.     # Returns win32s,95,98,Me,NT3.51,NT4,2000,XP/.Net
  1803.     # Returns nothing if not an MS system.
  1804.     # Contributed by: Yves Orton
  1805.  
  1806.     my $rpending_complaint = shift;
  1807.     return unless $^O =~ /win32|dos/i;    # is it a MS box?
  1808.  
  1809.     # It _should_ have Win32 unless something is really weird
  1810.     return unless eval('require Win32');
  1811.  
  1812.     # Use the standard API call to determine the version
  1813.     my ( $undef, $major, $minor, $build, $id ) = Win32::GetOSVersion();
  1814.  
  1815.     return "win32s" unless $id;           # If id==0 then its a win32s box.
  1816.     my $os = {                            # Magic numbers from MSDN
  1817.                                           # documentation of GetOSVersion
  1818.         1 => {
  1819.             0  => "95",
  1820.             10 => "98",
  1821.             90 => "Me"
  1822.         },
  1823.         2 => {
  1824.             0  => "2000",
  1825.             1  => "XP/.Net",
  1826.             51 => "NT3.51"
  1827.         }
  1828.     }->{$id}->{$minor};
  1829.  
  1830.     # This _really_ shouldnt happen. At least not for quite a while
  1831.     unless ( defined $os ) {
  1832.         $$rpending_complaint .= <<EOS;
  1833. Error trying to discover Win_OS_Type: $id:$major:$minor Has no name of record!
  1834. We won't be able to look for a system-wide config file.
  1835. EOS
  1836.     }
  1837.  
  1838.     # Unfortunately the logic used for the various versions isnt so clever..
  1839.     # so we have to handle an outside case.
  1840.     return ( $os eq "2000" & $major != 5 ) ? "NT4" : $os;
  1841. }
  1842.  
  1843. sub look_for_Windows {
  1844.  
  1845.     # determine Windows sub-type and location of
  1846.     # system-wide configuration files
  1847.     my $rpending_complaint = shift;
  1848.     my $is_Windows         = ( $^O =~ /win32|dos/i );
  1849.     my $Windows_type       = Win_OS_Type($rpending_complaint) if $is_Windows;
  1850.     return ( $is_Windows, $Windows_type );
  1851. }
  1852.  
  1853. sub find_config_file {
  1854.  
  1855.     # look for a .perltidyrc configuration file
  1856.     my ( $is_Windows, $Windows_type, $rconfig_file_chatter,
  1857.         $rpending_complaint ) = @_;
  1858.  
  1859.     $$rconfig_file_chatter .= "# Config file search...system reported as:";
  1860.     if ($is_Windows) {
  1861.         $$rconfig_file_chatter .= "Windows $Windows_type\n";
  1862.     }
  1863.     else {
  1864.         $$rconfig_file_chatter .= " $^O\n";
  1865.     }
  1866.  
  1867.     # sub to check file existance and record all tests
  1868.     my $exists_config_file = sub {
  1869.         my $config_file = shift;
  1870.         return 0 unless $config_file;
  1871.         $$rconfig_file_chatter .= "# Testing: $config_file\n";
  1872.         return -f $config_file;
  1873.     };
  1874.  
  1875.     my $config_file;
  1876.  
  1877.     # look in current directory first
  1878.     $config_file = ".perltidyrc";
  1879.     return $config_file if $exists_config_file->($config_file);
  1880.  
  1881.     # Default environment vars.
  1882.     my @envs = qw(PERLTIDY HOME);
  1883.  
  1884.     # Check the NT/2k/XP locations, first a local machine def, then a
  1885.     # network def
  1886.     push @envs, qw(USERPROFILE HOMESHARE) if $^O =~ /win32/i;
  1887.  
  1888.     # Now go through the enviornment ...
  1889.     foreach my $var (@envs) {
  1890.         $$rconfig_file_chatter .= "# Examining: \$ENV{$var}";
  1891.         if ( defined( $ENV{$var} ) ) {
  1892.             $$rconfig_file_chatter .= " = $ENV{$var}\n";
  1893.  
  1894.             # test ENV{ PERLTIDY } as file:
  1895.             if ( $var eq 'PERLTIDY' ) {
  1896.                 $config_file = "$ENV{$var}";
  1897.                 return $config_file if $exists_config_file->($config_file);
  1898.             }
  1899.  
  1900.             # test ENV as directory:
  1901.             $config_file = catfile( $ENV{$var}, ".perltidyrc" );
  1902.             return $config_file if $exists_config_file->($config_file);
  1903.         }
  1904.         else {
  1905.             $$rconfig_file_chatter .= "\n";
  1906.         }
  1907.     }
  1908.  
  1909.     # then look for a system-wide definition
  1910.     # where to look varies with OS
  1911.     if ($is_Windows) {
  1912.  
  1913.         if ($Windows_type) {
  1914.             my ( $os, $system, $allusers ) =
  1915.               Win_Config_Locs( $rpending_complaint, $Windows_type );
  1916.  
  1917.             # Check All Users directory, if there is one.
  1918.             if ($allusers) {
  1919.                 $config_file = catfile( $allusers, ".perltidyrc" );
  1920.                 return $config_file if $exists_config_file->($config_file);
  1921.             }
  1922.  
  1923.             # Check system directory.
  1924.             $config_file = catfile( $system, ".perltidyrc" );
  1925.             return $config_file if $exists_config_file->($config_file);
  1926.         }
  1927.     }
  1928.  
  1929.     # Place to add customization code for other systems
  1930.     elsif ( $^O eq 'OS2' ) {
  1931.     }
  1932.     elsif ( $^O eq 'MacOS' ) {
  1933.     }
  1934.     elsif ( $^O eq 'VMS' ) {
  1935.     }
  1936.  
  1937.     # Assume some kind of Unix
  1938.     else {
  1939.  
  1940.         $config_file = "/usr/local/etc/perltidyrc";
  1941.         return $config_file if $exists_config_file->($config_file);
  1942.  
  1943.         $config_file = "/etc/perltidyrc";
  1944.         return $config_file if $exists_config_file->($config_file);
  1945.     }
  1946.  
  1947.     # Couldn't find a config file
  1948.     return;
  1949. }
  1950.  
  1951. sub Win_Config_Locs {
  1952.  
  1953.     # In scalar context returns the OS name (95 98 ME NT3.51 NT4 2000 XP),
  1954.     # or undef if its not a win32 OS.  In list context returns OS, System
  1955.     # Directory, and All Users Directory.  All Users will be empty on a
  1956.     # 9x/Me box.  Contributed by: Yves Orton.
  1957.  
  1958.     my $rpending_complaint = shift;
  1959.     my $os = (@_) ? shift: Win_OS_Type();
  1960.     return unless $os;
  1961.  
  1962.     my $system   = "";
  1963.     my $allusers = "";
  1964.  
  1965.     if ( $os =~ /9[58]|Me/ ) {
  1966.         $system = "C:/Windows";
  1967.     }
  1968.     elsif ( $os =~ /NT|XP|2000/ ) {
  1969.         $system = ( $os =~ /XP/ ) ? "C:/Windows/" : "C:/WinNT/";
  1970.         $allusers =
  1971.           ( $os =~ /NT/ )
  1972.           ? "C:/WinNT/profiles/All Users/"
  1973.           : "C:/Documents and Settings/All Users/";
  1974.     }
  1975.     else {
  1976.  
  1977.         # This currently would only happen on a win32s computer.
  1978.         # I dont have one to test So I am unsure how to proceed.
  1979.         # Sorry. :-)
  1980.         $$rpending_complaint .=
  1981. "I dont know a sensible place to look for config files on an $os system.\n";
  1982.         return;
  1983.     }
  1984.     return wantarray ? ( $os, $system, $allusers ) : $os;
  1985. }
  1986.  
  1987. sub dump_config_file {
  1988.     my $fh                   = shift;
  1989.     my $config_file          = shift;
  1990.     my $rconfig_file_chatter = shift;
  1991.     print STDOUT "$$rconfig_file_chatter";
  1992.     if ($fh) {
  1993.         print STDOUT "# Dump of file: '$config_file'\n";
  1994.         while ( $_ = $fh->getline() ) { print STDOUT }
  1995.         eval { $fh->close() };
  1996.     }
  1997.     else {
  1998.         print STDOUT "# ...no config file found\n";
  1999.     }
  2000. }
  2001.  
  2002. sub read_config_file {
  2003.  
  2004.     my ( $fh, $config_file, $rexpansion ) = @_;
  2005.     my @config_list = ();
  2006.  
  2007.     my $name = undef;
  2008.     my $line_no;
  2009.     while ( $_ = $fh->getline() ) {
  2010.         $line_no++;
  2011.         chomp;
  2012.         next if /^\s*#/;    # skip full-line comment
  2013.         $_ = strip_comment( $_, $config_file, $line_no );
  2014.         s/^\s*(.*?)\s*$/$1/;    # trim both ends
  2015.         next unless $_;
  2016.  
  2017.         # look for something of the general form
  2018.         #    newname { body }
  2019.         # or just
  2020.         #    body
  2021.  
  2022.         if ( $_ =~ /^((\w+)\s*\{)?([^}]*)(\})?$/ ) {
  2023.             my ( $newname, $body, $curly ) = ( $2, $3, $4 );
  2024.  
  2025.             # handle a new alias definition
  2026.             if ($newname) {
  2027.                 if ($name) {
  2028.                     die
  2029. "No '}' seen after $name and before $newname in config file $config_file line $.\n";
  2030.                 }
  2031.                 $name = $newname;
  2032.  
  2033.                 if ( ${$rexpansion}{$name} ) {
  2034.                     local $" = ')(';
  2035.                     my @names = sort keys %$rexpansion;
  2036.                     print "Here is a list of all installed aliases\n(@names)\n";
  2037.                     die
  2038. "Attempting to redefine alias ($name) in config file $config_file line $.\n";
  2039.                 }
  2040.                 ${$rexpansion}{$name} = [];
  2041.             }
  2042.  
  2043.             # now do the body
  2044.             if ($body) {
  2045.  
  2046.                 my ( $rbody_parts, $msg ) = parse_args($body);
  2047.                 if ($msg) {
  2048.                     die <<EOM;
  2049. Error reading file $config_file at line number $line_no.
  2050. $msg
  2051. Please fix this line or use -npro to avoid reading this file
  2052. EOM
  2053.                 }
  2054.  
  2055.                 if ($name) {
  2056.  
  2057.                     # remove leading dashes if this is an alias
  2058.                     foreach (@$rbody_parts) { s/^\-+//; }
  2059.                     push @{ ${$rexpansion}{$name} }, @$rbody_parts;
  2060.                 }
  2061.  
  2062.                 else {
  2063.                     push ( @config_list, @$rbody_parts );
  2064.                 }
  2065.             }
  2066.  
  2067.             if ($curly) {
  2068.                 unless ($name) {
  2069.                     die
  2070. "Unexpected '}' seen in config file $config_file line $.\n";
  2071.                 }
  2072.                 $name = undef;
  2073.             }
  2074.         }
  2075.     }
  2076.     eval { $fh->close() };
  2077.     return ( \@config_list );
  2078. }
  2079.  
  2080. sub strip_comment {
  2081.  
  2082.     my ( $instr, $config_file, $line_no ) = @_;
  2083.  
  2084.     # nothing to do if no comments
  2085.     if ( $instr !~ /#/ ) {
  2086.         return $instr;
  2087.     }
  2088.  
  2089.     # use simple method of no quotes
  2090.     elsif ( $instr !~ /['"]/ ) {
  2091.         $instr =~ s/\s*\#.*$//;    # simple trim
  2092.         return $instr;
  2093.     }
  2094.  
  2095.     # handle comments and quotes
  2096.     my $outstr     = "";
  2097.     my $quote_char = "";
  2098.     while (1) {
  2099.  
  2100.         # looking for ending quote character
  2101.         if ($quote_char) {
  2102.             if ( $instr =~ /\G($quote_char)/gc ) {
  2103.                 $quote_char = "";
  2104.                 $outstr .= $1;
  2105.             }
  2106.             elsif ( $instr =~ /\G(.)/gc ) {
  2107.                 $outstr .= $1;
  2108.             }
  2109.  
  2110.             # error..we reached the end without seeing the ending quote char
  2111.             else {
  2112.                 die <<EOM;
  2113. Error reading file $config_file at line number $line_no.
  2114. Did not see ending quote character <$quote_char> in this text:
  2115. $instr
  2116. Please fix this line or use -npro to avoid reading this file
  2117. EOM
  2118.                 last;
  2119.             }
  2120.         }
  2121.  
  2122.         # accumulating characters and looking for start of a quoted string
  2123.         else {
  2124.             if ( $instr =~ /\G([\"\'])/gc ) {
  2125.                 $outstr .= $1;
  2126.                 $quote_char = $1;
  2127.             }
  2128.             elsif ( $instr =~ /\G#/gc ) {
  2129.                 last;
  2130.             }
  2131.             elsif ( $instr =~ /\G(.)/gc ) {
  2132.                 $outstr .= $1;
  2133.             }
  2134.             else {
  2135.                 last;
  2136.             }
  2137.         }
  2138.     }
  2139.     return $outstr;
  2140. }
  2141.  
  2142. sub parse_args {
  2143.  
  2144.     # Parse a command string containing multiple string with possible
  2145.     # quotes, into individual commands.  It might look like this, for example:
  2146.     #
  2147.     #    -wba=" + - "  -some-thing -wbb='. && ||'
  2148.     #
  2149.     # There is no need, at present, to handle escaped quote characters.
  2150.     # (They are not perltidy tokens, so needn't be in strings).
  2151.  
  2152.     my ($body) = @_;
  2153.     my @body_parts = ();
  2154.     my $quote_char = "";
  2155.     my $part       = "";
  2156.     my $msg        = "";
  2157.     while (1) {
  2158.  
  2159.         # looking for ending quote character
  2160.         if ($quote_char) {
  2161.             if ( $body =~ /\G($quote_char)/gc ) {
  2162.                 $quote_char = "";
  2163.             }
  2164.             elsif ( $body =~ /\G(.)/gc ) {
  2165.                 $part .= $1;
  2166.             }
  2167.  
  2168.             # error..we reached the end without seeing the ending quote char
  2169.             else {
  2170.                 if ($part) { push @body_parts, $part; }
  2171.                 $msg = <<EOM;
  2172. Did not see ending quote character <$quote_char> in this text:
  2173. $body
  2174. EOM
  2175.                 last;
  2176.             }
  2177.         }
  2178.  
  2179.         # accumulating characters and looking for start of a quoted string
  2180.         else {
  2181.             if ( $body =~ /\G([\"\'])/gc ) {
  2182.                 $quote_char = $1;
  2183.             }
  2184.             elsif ( $body =~ /\G(\s+)/gc ) {
  2185.                 if ($part) { push @body_parts, $part; }
  2186.                 $part = "";
  2187.             }
  2188.             elsif ( $body =~ /\G(.)/gc ) {
  2189.                 $part .= $1;
  2190.             }
  2191.             else {
  2192.                 if ($part) { push @body_parts, $part; }
  2193.                 last;
  2194.             }
  2195.         }
  2196.     }
  2197.     return ( \@body_parts, $msg );
  2198. }
  2199.  
  2200. sub dump_long_names {
  2201.  
  2202.     my @names = sort @_;
  2203.     print STDOUT <<EOM;
  2204. # Command line long names (passed to GetOptions)
  2205. #---------------------------------------------------------------
  2206. # here is a summary of the Getopt codes:
  2207. # <none> does not take an argument
  2208. # =s takes a mandatory string
  2209. # :s takes an optional string
  2210. # =i takes a mandatory integer
  2211. # :i takes an optional integer
  2212. # ! does not take an argument and may be negated
  2213. #  i.e., -foo and -nofoo are allowed
  2214. # a double dash signals the end of the options list
  2215. #
  2216. #---------------------------------------------------------------
  2217. EOM
  2218.  
  2219.     foreach (@names) { print STDOUT "$_\n" }
  2220. }
  2221.  
  2222. sub dump_defaults {
  2223.     my @defaults = sort @_;
  2224.     print STDOUT "Default command line options:\n";
  2225.     foreach (@_) { print STDOUT "$_\n" }
  2226. }
  2227.  
  2228. sub dump_options {
  2229.     my ($rOpts) = @_;
  2230.     local $" = "\n";
  2231.     print STDOUT "Final parameter set for this run\n";
  2232.     foreach ( sort keys %{$rOpts} ) {
  2233.         print STDOUT "$_=$rOpts->{$_}\n";
  2234.     }
  2235. }
  2236.  
  2237. sub show_version {
  2238.     print <<"EOM";
  2239. This is perltidy, v$VERSION 
  2240.  
  2241. Copyright 2000-2002, Steve Hancock
  2242.  
  2243. Perltidy is free software and may be copied under the terms of the GNU
  2244. General Public License, which is included in the distribution files.
  2245.  
  2246. Complete documentation for perltidy can be found using 'man perltidy'
  2247. or on the internet at http://perltidy.sourceforge.net.
  2248. EOM
  2249. }
  2250.  
  2251. sub usage {
  2252.  
  2253.     print STDOUT <<EOF;
  2254. This is perltidy version $VERSION, a perl script indenter.  Usage:
  2255.  
  2256.     perltidy [ options ] file1 file2 file3 ...
  2257.             (output goes to file1.tdy, file2.tdy, file3.tdy, ...)
  2258.     perltidy [ options ] file1 -o outfile
  2259.     perltidy [ options ] file1 -st >outfile
  2260.     perltidy [ options ] <infile >outfile
  2261.  
  2262. Options have short and long forms. Short forms are shown; see
  2263. man pages for long forms.  Note: '=s' indicates a required string,
  2264. and '=n' indicates a required integer.
  2265.  
  2266. I/O control
  2267.  -h      show this help
  2268.  -o=file name of the output file (only if single input file)
  2269.  -oext=s change output extension from 'tdy' to s
  2270.  -opath=path  change path to be 'path' for output files
  2271.  -b      backup original to .bak and modify file in-place
  2272.  -bext=s change default backup extension from 'bak' to s
  2273.  -q      deactivate error messages (for running under editor)
  2274.  -w      include non-critical warning messages in the .ERR error output
  2275.  -syn    run perl -c to check syntax (default under unix systems)
  2276.  -log    save .LOG file, which has useful diagnostics
  2277.  -f      force perltidy to read a binary file
  2278.  -g      like -log but writes more detailed .LOG file, for debugging scripts
  2279.  -opt    write the set of options actually used to a .LOG file
  2280.  -npro   ignore .perltidyrc configuration command file 
  2281.  -pro=file   read configuration commands from file instead of .perltidyrc 
  2282.  -st     send output to standard output, STDOUT
  2283.  -se     send error output to standard error output, STDERR
  2284.  -v      display version number to standard output and quit
  2285.  
  2286. Basic Options:
  2287.  -i=n    use n columns per indentation level (default n=4)
  2288.  -t      tabs: use one tab character per indentation level, not recommeded
  2289.  -nt     no tabs: use n spaces per indentation level (default)
  2290.  -et=n   entab leading whitespace n spaces per tab; not recommended
  2291.  -io     "indent only": just do indentation, no other formatting.
  2292.  -sil=n  set starting indentation level to n;  use if auto detection fails
  2293.  
  2294. Whitespace Control
  2295.  -fws    freeze whitespace; this disables all whitespace changes
  2296.            and disables the following switches:
  2297.  -bt=n   sets brace tightness,  n= (0 = loose, 1=default, 2 = tight)
  2298.  -bbt    same as -bt but for code block braces; same as -bt if not given
  2299.  -bbvt   block braces vertically tight; use with -bl or -bli
  2300.  -bbvtl=s  make -bbvt to apply to selected list of block types
  2301.  -pt=n   paren tightness (n=0, 1 or 2)
  2302.  -sbt=n  square bracket tightness (n=0, 1, or 2)
  2303.  -bvt=n  brace vertical tightness, 
  2304.          n=(0=open, 1=close unless multiple steps on a line, 2=always close)
  2305.  -pvt=n  paren vertical tightness (see -bvt for n)
  2306.  -sbvt=n square bracket vertical tightness (see -bvt for n)
  2307.  -bvtc=n closing brace vertical tightness: 
  2308.          n=(0=open, 1=sometimes close, 2=always close)
  2309.  -pvtc=n closing paren vertical tightness, see -bvtc for n.
  2310.  -sbvtc=n closing square bracket vertical tightness, see -bvtc for n.
  2311.  -ci=n   sets continuation indentation=n,  default is n=2 spaces
  2312.  -lp     line up parentheses, brackets, and non-BLOCK braces
  2313.  -sfs    add space before semicolon in for( ; ; )
  2314.  -aws    allow perltidy to add whitespace (default)
  2315.  -dws    delete all old non-essential whitespace 
  2316.  -icb    indent closing brace of a code block
  2317.  -icp    indent closing paren, square-bracket, or brace of non code block
  2318.  -wls=s  want space left of tokens in string; i.e. -nwls='+ - * /'
  2319.  -wrs=s  want space right of tokens in string;
  2320.  -sts    put space before terminal semicolon of a statement
  2321.  
  2322. Line Break Control
  2323.  -fnl    freeze newlines; this disables all line break changes
  2324.             and disables the following switches:
  2325.  -anl    add newlines;  ok to introduce new line breaks
  2326.  -bbs    add blank line before subs and packages
  2327.  -bbc    add blank line before block comments
  2328.  -bbb    add blank line between major blocks
  2329.  -sob    swallow optional blank lines
  2330.  -ce     cuddled else; use this style: '} else {'
  2331.  -dnl    delete old newlines (default)
  2332.  -mbl=n  maximum consecutive blank lines (default=1)
  2333.  -l=n    maximum line length;  default n=80
  2334.  -bl     opening brace on new line 
  2335.  -sbl    opening sub brace on new line.  value of -bl is used if not given.
  2336.  -bli    opening brace on new line and indented
  2337.  -bar    opening brace always on right, even for long clauses
  2338.  -vt=n   vertical tightness (requires -lp); n controls break after opening
  2339.          token: 0=never  1=no break if next line balanced   2=no break
  2340.  -vtc=n  vertical tightness of closing container; n controls if closing
  2341.          token starts new line: 0=always  1=not unless list  1=never
  2342.  -wba=s  want break after tokens in string; i.e. wba=': .'
  2343.  -wbb=s  want break before tokens in string
  2344.  
  2345. Following Old Breakpoints
  2346.  -boc    break at old comma breaks: turns off all automatic list formatting
  2347.  -bol    break at old logical breakpoints: or, and, ||, && (default)
  2348.  -bok    break at old list keyword breakpoints such as map, sort (default)
  2349.  -bot    break at old conditional (trinary ?:) operator breakpoints (default)
  2350.  -cab=n  break at commas after a comma-arrow (=>):
  2351.          n=0 break at all commas after =>
  2352.          n=1 stable: break unless this breaks an existing one-line container
  2353.          n=2 break only if a one-line container cannot be formed
  2354.          n=3 do not treat commas after => specially at all
  2355.  
  2356. Comment controls
  2357.  -ibc    indent block comments (default)
  2358.  -isbc   indent spaced block comments; may indent unless no leading space
  2359.  -msc=n  minimum desired spaces to side comment, default 4
  2360.  -csc    add or update closing side comments after closing BLOCK brace
  2361.  -dcsc   delete closing side comments created by a -csc command
  2362.  -cscp=s change closing side comment prefix to be other than '## end'
  2363.  -cscl=s change closing side comment to apply to selected list of blocks
  2364.  -csci=n minimum number of lines needed to apply a -csc tag, default n=6
  2365.  -csct=n maximum number of columns of appended text, default n=20 
  2366.  -cscw   causes warning if old side comment is overwritten with -csc
  2367.  
  2368.  -sbc    use 'static block comments' identified by leading '##' (default)
  2369.  -sbcp=s change static block comment identifier to be other than '##'
  2370.  -osbc   outdent static block comments
  2371.  
  2372.  -ssc    use 'static side comments' identified by leading '##' (default)
  2373.  -sscp=s change static side comment identifier to be other than '##'
  2374.  
  2375. Delete selected text
  2376.  -dac    delete all comments AND pod
  2377.  -dbc    delete block comments     
  2378.  -dsc    delete side comments  
  2379.  -dp     delete pod
  2380.  
  2381. Send selected text to a '.TEE' file
  2382.  -tac    tee all comments AND pod
  2383.  -tbc    tee block comments       
  2384.  -tsc    tee side comments       
  2385.  -tp     tee pod           
  2386.  
  2387. Outdenting
  2388.  -olq    outdent long quoted strings (default) 
  2389.  -olc    outdent a long block comment line
  2390.  -ola    outdent statement labels
  2391.  -okw    outdent control keywords (redo, next, last, goto, return)
  2392.  -okwl=s specify alternative keywords for -okw command
  2393.  
  2394. Other controls
  2395.  -mft=n  maximum fields per table; default n=40
  2396.  -x      do not format lines before hash-bang line (i.e., for VMS)
  2397.  -asc    allows perltidy to add a ';' when missing (default)
  2398.  -dsm    allows perltidy to delete an unnecessary ';'  (default)
  2399.  
  2400. Combinations of other parameters
  2401.  -gnu     attempt to follow GNU Coding Standards as applied to perl
  2402.  -mangle  remove as many newlines as possible (but keep comments and pods)
  2403.  -extrude  insert as many newlines as possible
  2404.  
  2405. Dump and die, debugging
  2406.  -dop    dump options used in this run to standard output and quit
  2407.  -ddf    dump default options to standard output and quit
  2408.  -dsn    dump all option short names to standard output and quit
  2409.  -dln    dump option long names to standard output and quit
  2410.  -dpro   dump whatever configuration file is in effect to standard output
  2411.  -dtt    dump all token types to standard output and quit
  2412.  
  2413. HTML
  2414.  -html write an html file (see 'man perl2web' for many options)
  2415.        Note: when -html is used, no indentation or formatting are done.
  2416.        Hint: try perltidy -html -css=mystyle.css filename.pl
  2417.        and edit mystyle.css to change the appearance of filename.html.
  2418.        -nnn gives line numbers
  2419.        -pre only writes out <pre>..</pre> code section
  2420.        -toc places a table of contents to subs at the top (default)
  2421.        -pod passes pod text through pod2html (default)
  2422.        -frm write html as a frame (3 files)
  2423.        -text=s extra extension for table of contents if -frm, default='toc'
  2424.        -sext=s extra extension for file content if -frm, default='src'
  2425.  
  2426. A prefix of "n" negates short form toggle switches, and a prefix of "no"
  2427. negates the long forms.  For example, -nasc means don't add missing
  2428. semicolons.  
  2429.  
  2430. If you are unable to see this entire text, try "perltidy -h | more"
  2431. For more detailed information, and additional options, try "man perltidy",
  2432. or go to the perltidy home page at http://perltidy.sourceforge.net
  2433. EOF
  2434.  
  2435. }
  2436.  
  2437. sub process_this_file {
  2438.  
  2439.     my ( $truth, $beauty ) = @_;
  2440.  
  2441.     # loop to process each line of this file
  2442.     while ( my $line_of_tokens = $truth->get_line() ) {
  2443.         $beauty->write_line($line_of_tokens);
  2444.     }
  2445.  
  2446.     # finish up
  2447.     $beauty->finish_formatting();
  2448.     $truth->report_tokenization_errors();
  2449. }
  2450.  
  2451. sub check_syntax {
  2452.  
  2453.     # Use 'perl -c' to make sure that we did not create bad syntax
  2454.     # This is a very good independent check for programming errors
  2455.     #
  2456.     # Given names of the input and output files, ($ifname, $ofname),
  2457.     # we do the following:
  2458.     # - check syntax of the input file
  2459.     # - if bad, all done (could be an incomplete code snippet)
  2460.     # - if infile syntax ok, then check syntax of the output file;
  2461.     #   - if outfile syntax bad, issue warning; this implies a code bug!
  2462.     # - set and return flag "infile_syntax_ok" : =-1 bad 0 unknown 1 good
  2463.  
  2464.     my ( $ifname, $ofname, $logger_object, $rOpts ) = @_;
  2465.     my $infile_syntax_ok = 0;
  2466.     my $line_of_dashes   = '-' x 42 . "\n";
  2467.  
  2468.     my $flags = $rOpts->{'perl-syntax-check-flags'};
  2469.  
  2470.     # be sure we invoke perl with -c
  2471.     # note: perl will accept repeated flags like '-c -c'.  It is safest
  2472.     # to append another -c than try to find an interior bundled c, as
  2473.     # in -Tc, because such a 'c' might be in a quoted string, for example.
  2474.     if ( $flags !~ /(^-c|\s+-c)/ ) { $flags .= " -c" }
  2475.  
  2476.     # be sure we invoke perl with -x if requested
  2477.     # same comments about repeated parameters applies
  2478.     if ( $rOpts->{'look-for-hash-bang'} ) {
  2479.         if ( $flags !~ /(^-x|\s+-x)/ ) { $flags .= " -x" }
  2480.     }
  2481.  
  2482.     # this shouldn't happen unless a termporary file couldn't be made
  2483.     if ( $ifname eq '-' ) {
  2484.         $logger_object->write_logfile_entry(
  2485.             "Cannot run perl -c on STDIN and STDOUT\n");
  2486.         return $infile_syntax_ok;
  2487.     }
  2488.  
  2489.     $logger_object->write_logfile_entry(
  2490.         "checking input file syntax with perl $flags\n");
  2491.     $logger_object->write_logfile_entry($line_of_dashes);
  2492.  
  2493.     # Not all operating systems/shells support redirection of the standard
  2494.     # error output.
  2495.     my $error_redirection = ( $^O eq 'VMS' ) ? "" : '2>&1';
  2496.  
  2497.     my $perl_output = do_syntax_check( $ifname, $flags, $error_redirection );
  2498.     $logger_object->write_logfile_entry("$perl_output\n");
  2499.  
  2500.     if ( $perl_output =~ /syntax\s*OK/ ) {
  2501.         $infile_syntax_ok = 1;
  2502.         $logger_object->write_logfile_entry($line_of_dashes);
  2503.         $logger_object->write_logfile_entry(
  2504.             "checking output file syntax with perl $flags ...\n");
  2505.         $logger_object->write_logfile_entry($line_of_dashes);
  2506.  
  2507.         my $perl_output =
  2508.           do_syntax_check( $ofname, $flags, $error_redirection );
  2509.         $logger_object->write_logfile_entry("$perl_output\n");
  2510.  
  2511.         unless ( $perl_output =~ /syntax\s*OK/ ) {
  2512.             $logger_object->write_logfile_entry($line_of_dashes);
  2513.             $logger_object->warning(
  2514. "The output file has a syntax error when tested with perl $flags $ofname !\n"
  2515.             );
  2516.             $logger_object->warning(
  2517.                 "This implies an error in perltidy; the file $ofname is bad\n");
  2518.             $logger_object->report_definite_bug();
  2519.  
  2520.             # the perl version number will be helpful for diagnosing the problem
  2521.             $logger_object->write_logfile_entry(
  2522.                 qx/perl -v $error_redirection/ . "\n" );
  2523.         }
  2524.     }
  2525.     else {
  2526.  
  2527.         # Only warn of perl -c syntax errors.  Other messages,
  2528.         # such as missing modules, are too common.  They can be
  2529.         # seen by running with perltidy -w
  2530.         $logger_object->complain("A syntax check using perl $flags gives: \n");
  2531.         $logger_object->complain($line_of_dashes);
  2532.         $logger_object->complain("$perl_output\n");
  2533.         $logger_object->complain($line_of_dashes);
  2534.         $infile_syntax_ok = -1;
  2535.         $logger_object->write_logfile_entry($line_of_dashes);
  2536.         $logger_object->write_logfile_entry(
  2537. "The output file will not be checked because of input file problems\n"
  2538.         );
  2539.     }
  2540.     return $infile_syntax_ok;
  2541. }
  2542.  
  2543. sub do_syntax_check {
  2544.     my ( $fname, $flags, $error_redirection ) = @_;
  2545.  
  2546.     # We have to quote the filename in case it has unusual characters
  2547.     # or spaces.  Example: this filename #CM11.pm# gives trouble.
  2548.     $fname = '"' . $fname . '"';
  2549.  
  2550.     # Under VMS something like -T will become -t (and an error) so we
  2551.     # will put quotes around the flags.  Double quotes seem to work on
  2552.     # Unix/Windows/VMS, but this may not work on all systems.  (Single
  2553.     # quotes do not work under Windows).  It could become necessary to
  2554.     # put double quotes around each flag, such as:  -"c"  -"T"
  2555.     # We may eventually need some system-dependent coding here.
  2556.     $flags = '"' . $flags . '"';
  2557.  
  2558.     # now wish for luck...
  2559.     return qx/perl $flags $fname $error_redirection/;
  2560. }
  2561.  
  2562. #####################################################################
  2563. #
  2564. # This is a stripped down version of IO::Scalar
  2565. # Given a reference to a scalar, it supplies either:
  2566. # a getline method which reads lines (mode='r'), or
  2567. # a print method which reads lines (mode='w')
  2568. #
  2569. #####################################################################
  2570. package Perl::Tidy::IOScalar;
  2571. use Carp;
  2572.  
  2573. sub new {
  2574.     my ( $package, $rscalar, $mode ) = @_;
  2575.     my $ref = ref $rscalar;
  2576.     if ( $ref ne 'SCALAR' ) {
  2577.         confess <<EOM;
  2578. ------------------------------------------------------------------------
  2579. expecting ref to SCALAR but got ref to ($ref); trace follows:
  2580. ------------------------------------------------------------------------
  2581. EOM
  2582.  
  2583.     }
  2584.     if ( $mode eq 'w' ) {
  2585.         $$rscalar = "";
  2586.         return bless [ $rscalar, $mode ], $package;
  2587.     }
  2588.     elsif ( $mode eq 'r' ) {
  2589.  
  2590.         # Convert a scalar to an array.
  2591.         # This avoids looking for "\n" on each call to getline
  2592.         my @array = map { $_ .= "\n" } split /\n/, ${$rscalar};
  2593.         my $i_next = 0;
  2594.         return bless [ \@array, $mode, $i_next ], $package;
  2595.     }
  2596.     else {
  2597.         confess <<EOM;
  2598. ------------------------------------------------------------------------
  2599. expecting mode = 'r' or 'w' but got mode ($mode); trace follows:
  2600. ------------------------------------------------------------------------
  2601. EOM
  2602.     }
  2603. }
  2604.  
  2605. sub getline {
  2606.     my $self = shift;
  2607.     my $mode = $self->[1];
  2608.     if ( $mode ne 'r' ) {
  2609.         confess <<EOM;
  2610. ------------------------------------------------------------------------
  2611. getline call requires mode = 'r' but mode = ($mode); trace follows:
  2612. ------------------------------------------------------------------------
  2613. EOM
  2614.     }
  2615.     my $i    = $self->[2]++;
  2616.     my $line = $self->[0]->[$i];
  2617.     return $self->[0]->[$i];
  2618. }
  2619.  
  2620. sub print {
  2621.     my $self = shift;
  2622.     my $mode = $self->[1];
  2623.     if ( $mode ne 'w' ) {
  2624.         confess <<EOM;
  2625. ------------------------------------------------------------------------
  2626. print call requires mode = 'w' but mode = ($mode); trace follows:
  2627. ------------------------------------------------------------------------
  2628. EOM
  2629.     }
  2630.     ${ $self->[0] } .= $_[0];
  2631. }
  2632. sub close { return }
  2633.  
  2634. #####################################################################
  2635. #
  2636. # This is a stripped down version of IO::ScalarArray
  2637. # Given a reference to an array, it supplies either:
  2638. # a getline method which reads lines (mode='r'), or
  2639. # a print method which reads lines (mode='w')
  2640. #
  2641. #####################################################################
  2642. package Perl::Tidy::IOScalarArray;
  2643. use Carp;
  2644.  
  2645. sub new {
  2646.     my ( $package, $rarray, $mode ) = @_;
  2647.     my $ref = ref $rarray;
  2648.     if ( $ref ne 'ARRAY' ) {
  2649.         confess <<EOM;
  2650. ------------------------------------------------------------------------
  2651. expecting ref to ARRAY but got ref to ($ref); trace follows:
  2652. ------------------------------------------------------------------------
  2653. EOM
  2654.  
  2655.     }
  2656.     if ( $mode eq 'w' ) {
  2657.         @$rarray = ();
  2658.         return bless [ $rarray, $mode ], $package;
  2659.     }
  2660.     elsif ( $mode eq 'r' ) {
  2661.         my $i_next = 0;
  2662.         return bless [ $rarray, $mode, $i_next ], $package;
  2663.     }
  2664.     else {
  2665.         confess <<EOM;
  2666. ------------------------------------------------------------------------
  2667. expecting mode = 'r' or 'w' but got mode ($mode); trace follows:
  2668. ------------------------------------------------------------------------
  2669. EOM
  2670.     }
  2671. }
  2672.  
  2673. sub getline {
  2674.     my $self = shift;
  2675.     my $mode = $self->[1];
  2676.     if ( $mode ne 'r' ) {
  2677.         confess <<EOM;
  2678. ------------------------------------------------------------------------
  2679. getline requires mode = 'r' but mode = ($mode); trace follows:
  2680. ------------------------------------------------------------------------
  2681. EOM
  2682.     }
  2683.     my $i    = $self->[2]++;
  2684.     my $line = $self->[0]->[$i];
  2685.     return $self->[0]->[$i];
  2686. }
  2687.  
  2688. sub print {
  2689.     my $self = shift;
  2690.     my $mode = $self->[1];
  2691.     if ( $mode ne 'w' ) {
  2692.         confess <<EOM;
  2693. ------------------------------------------------------------------------
  2694. print requires mode = 'w' but mode = ($mode); trace follows:
  2695. ------------------------------------------------------------------------
  2696. EOM
  2697.     }
  2698.     push @{ $self->[0] }, $_[0];
  2699. }
  2700. sub close { return }
  2701.  
  2702. #####################################################################
  2703. #
  2704. # the Perl::Tidy::LineSource class supplies an object with a 'get_line()' method
  2705. # which returns the next line to be parsed
  2706. #
  2707. #####################################################################
  2708.  
  2709. package Perl::Tidy::LineSource;
  2710.  
  2711. sub new {
  2712.  
  2713.     my ( $class, $input_file, $rOpts, $rpending_logfile_message ) = @_;
  2714.     my $input_file_copy = undef;
  2715.     my $fh_copy;
  2716.  
  2717.     ( my $fh, $input_file ) = Perl::Tidy::streamhandle( $input_file, 'r' );
  2718.     return undef unless $fh;
  2719.  
  2720.     # in order to check output syntax when standard output is used,
  2721.     # or when it is an object, we have to make a copy of the file
  2722.     if ( ( $input_file eq '-' || ref $input_file ) && $rOpts->{'check-syntax'} )
  2723.     {
  2724.  
  2725.         # Turning off syntax check when input output is used.
  2726.         # The reason is that temporary files cause problems on
  2727.         # on many systems.
  2728.         $rOpts->{'check-syntax'} = 0;
  2729.         $input_file_copy = '-';
  2730.  
  2731.         $$rpending_logfile_message .= <<EOM;
  2732. Note: --syntax check will be skipped because standard input is used
  2733. EOM
  2734.  
  2735.     }
  2736.  
  2737.     return bless {
  2738.         _fh              => $fh,
  2739.         _fh_copy         => $fh_copy,
  2740.         _filename        => $input_file,
  2741.         _input_file_copy => $input_file_copy,
  2742.     }, $class;
  2743. }
  2744.  
  2745. sub get_input_file_copy_name {
  2746.     my $self   = shift;
  2747.     my $ifname = $self->{_input_file_copy};
  2748.     unless ($ifname) {
  2749.         $ifname = $self->{_filename};
  2750.     }
  2751.     return $ifname;
  2752. }
  2753.  
  2754. sub close_input_file {
  2755.     my $self = shift;
  2756.     eval { $self->{_fh}->close() };
  2757.     eval { $self->{_fh_copy}->close() } if $self->{_fh_copy};
  2758. }
  2759.  
  2760. sub get_line {
  2761.     my $self    = shift;
  2762.     my $line    = undef;
  2763.     my $fh      = $self->{_fh};
  2764.     my $fh_copy = $self->{_fh_copy};
  2765.     $line = $fh->getline();
  2766.     if ( $line && $fh_copy ) { $fh_copy->print($line); }
  2767.     return $line;
  2768. }
  2769.  
  2770. #####################################################################
  2771. #
  2772. # the Perl::Tidy::LineSink class supplies a write_line method for
  2773. # actual file writing
  2774. #
  2775. #####################################################################
  2776.  
  2777. package Perl::Tidy::LineSink;
  2778.  
  2779. sub new {
  2780.  
  2781.     my ( $class, $output_file, $tee_file, $rOpts, $rpending_logfile_message ) =
  2782.       @_;
  2783.     my $fh               = undef;
  2784.     my $fh_copy          = undef;
  2785.     my $fh_tee           = undef;
  2786.     my $output_file_copy = "";
  2787.     my $output_file_open = 0;
  2788.  
  2789.     if ( $rOpts->{'format'} eq 'tidy' ) {
  2790.         ( $fh, $output_file ) = Perl::Tidy::streamhandle( $output_file, 'w' );
  2791.         unless ($fh) { die "Cannot write to output stream\n"; }
  2792.         $output_file_open = 1;
  2793.     }
  2794.  
  2795.     # in order to check output syntax when standard output is used,
  2796.     # or when it is an object, we have to make a copy of the file
  2797.     if ( $output_file eq '-' || ref $output_file ) {
  2798.         if ( $rOpts->{'check-syntax'} ) {
  2799.  
  2800.             # Turning off syntax check when standard output is used.
  2801.             # The reason is that temporary files cause problems on
  2802.             # on many systems.
  2803.             $rOpts->{'check-syntax'} = 0;
  2804.             $output_file_copy = '-';
  2805.             $$rpending_logfile_message .= <<EOM;
  2806. Note: --syntax check will be skipped because standard output is used
  2807. EOM
  2808.  
  2809.         }
  2810.     }
  2811.  
  2812.     bless {
  2813.         _fh               => $fh,
  2814.         _fh_copy          => $fh_copy,
  2815.         _fh_tee           => $fh_tee,
  2816.         _output_file      => $output_file,
  2817.         _output_file_open => $output_file_open,
  2818.         _output_file_copy => $output_file_copy,
  2819.         _tee_flag         => 0,
  2820.         _tee_file         => $tee_file,
  2821.         _tee_file_opened  => 0,
  2822.     }, $class;
  2823. }
  2824.  
  2825. sub write_line {
  2826.  
  2827.     my $self    = shift;
  2828.     my $fh      = $self->{_fh};
  2829.     my $fh_copy = $self->{_fh_copy};
  2830.  
  2831.     my $output_file_open = $self->{_output_file_open};
  2832.  
  2833.     $fh->print( $_[0] ) if ( $self->{_output_file_open} );
  2834.     print $fh_copy $_[0] if ( $fh_copy && $self->{_output_file_copy} );
  2835.  
  2836.     if ( $self->{_tee_flag} ) {
  2837.         unless ( $self->{_tee_file_opened} ) { $self->really_open_tee_file() }
  2838.         my $fh_tee = $self->{_fh_tee};
  2839.         print $fh_tee $_[0];
  2840.     }
  2841. }
  2842.  
  2843. sub get_output_file_copy {
  2844.     my $self   = shift;
  2845.     my $ofname = $self->{_output_file_copy};
  2846.     unless ($ofname) {
  2847.         $ofname = $self->{_output_file};
  2848.     }
  2849.     return $ofname;
  2850. }
  2851.  
  2852. sub tee_on {
  2853.     my $self = shift;
  2854.     $self->{_tee_flag} = 1;
  2855. }
  2856.  
  2857. sub tee_off {
  2858.     my $self = shift;
  2859.     $self->{_tee_flag} = 0;
  2860. }
  2861.  
  2862. sub really_open_tee_file {
  2863.     my $self     = shift;
  2864.     my $tee_file = $self->{_tee_file};
  2865.     my $fh_tee;
  2866.     $fh_tee = IO::File->new(">$tee_file")
  2867.       or die ("couldn't open TEE file $tee_file: $!\n");
  2868.     $self->{_tee_file_opened} = 1;
  2869.     $self->{_fh_tee}          = $fh_tee;
  2870. }
  2871.  
  2872. sub close_output_file {
  2873.     my $self = shift;
  2874.     eval { $self->{_fh}->close() }      if $self->{_output_file_open};
  2875.     eval { $self->{_fh_copy}->close() } if ( $self->{_output_file_copy} );
  2876.     $self->close_tee_file();
  2877. }
  2878.  
  2879. sub close_tee_file {
  2880.     my $self = shift;
  2881.  
  2882.     if ( $self->{_tee_file_opened} ) {
  2883.         eval { $self->{_fh_tee}->close() };
  2884.         $self->{_tee_file_opened} = 0;
  2885.     }
  2886. }
  2887.  
  2888. #####################################################################
  2889. #
  2890. # The Perl::Tidy::Diagnostics class writes the DIAGNOSTICS file, which is
  2891. # useful for program development.
  2892. #
  2893. # Only one such file is created regardless of the number of input
  2894. # files processed.  This allows the results of processing many files
  2895. # to be summarized in a single file.
  2896. #
  2897. #####################################################################
  2898.  
  2899. package Perl::Tidy::Diagnostics;
  2900.  
  2901. sub new {
  2902.  
  2903.     my $class = shift;
  2904.     bless {
  2905.         _write_diagnostics_count => 0,
  2906.         _last_diagnostic_file    => "",
  2907.         _input_file              => "",
  2908.         _fh                      => undef,
  2909.     }, $class;
  2910. }
  2911.  
  2912. sub set_input_file {
  2913.     my $self = shift;
  2914.     $self->{_input_file} = $_[0];
  2915. }
  2916.  
  2917. # This is a diagnostic routine which is useful for program development.
  2918. # Output from debug messages go to a file named DIAGNOSTICS, where
  2919. # they are labeled by file and line.  This allows many files to be
  2920. # scanned at once for some particular condition of interest.
  2921. sub write_diagnostics {
  2922.     my $self = shift;
  2923.  
  2924.     unless ( $self->{_write_diagnostics_count} ) {
  2925.         open DIAGNOSTICS, ">DIAGNOSTICS"
  2926.           or death("couldn't open DIAGNOSTICS: $!\n");
  2927.     }
  2928.  
  2929.     my $last_diagnostic_file = $self->{_last_diagnostic_file};
  2930.     my $input_file           = $self->{_input_file};
  2931.     if ( $last_diagnostic_file ne $input_file ) {
  2932.         print DIAGNOSTICS "\nFILE:$input_file\n";
  2933.     }
  2934.     $self->{_last_diagnostic_file} = $input_file;
  2935.     my $input_line_number = Perl::Tidy::Tokenizer::get_input_line_number();
  2936.     print DIAGNOSTICS "$input_line_number:\t@_";
  2937.     $self->{_write_diagnostics_count}++;
  2938. }
  2939.  
  2940. #####################################################################
  2941. #
  2942. # The Perl::Tidy::Logger class writes the .LOG and .ERR files
  2943. #
  2944. #####################################################################
  2945.  
  2946. package Perl::Tidy::Logger;
  2947.  
  2948. sub new {
  2949.     my $class = shift;
  2950.     my $fh;
  2951.     my ( $rOpts, $log_file, $warning_file, $saw_extrude ) = @_;
  2952.  
  2953.     # remove any old error output file
  2954.     unless ( ref($warning_file) ) {
  2955.         if ( -e $warning_file ) { unlink($warning_file) }
  2956.     }
  2957.  
  2958.     bless {
  2959.         _log_file                      => $log_file,
  2960.         _fh_warnings                   => undef,
  2961.         _rOpts                         => $rOpts,
  2962.         _fh_warnings                   => undef,
  2963.         _last_input_line_written       => 0,
  2964.         _at_end_of_file                => 0,
  2965.         _use_prefix                    => 1,
  2966.         _block_log_output              => 0,
  2967.         _line_of_tokens                => undef,
  2968.         _output_line_number            => undef,
  2969.         _wrote_line_information_string => 0,
  2970.         _wrote_column_headings         => 0,
  2971.         _warning_file                  => $warning_file,
  2972.         _warning_count                 => 0,
  2973.         _complaint_count               => 0,
  2974.         _saw_code_bug    => -1,             # -1=no 0=maybe 1=for sure
  2975.         _saw_brace_error => 0,
  2976.         _saw_extrude     => $saw_extrude,
  2977.         _output_array    => [],
  2978.     }, $class;
  2979. }
  2980.  
  2981. sub close_log_file {
  2982.  
  2983.     my $self = shift;
  2984.     if ( $self->{_fh_warnings} ) {
  2985.         eval { $self->{_fh_warnings}->close() };
  2986.         $self->{_fh_warnings} = undef;
  2987.     }
  2988. }
  2989.  
  2990. sub get_warning_count {
  2991.     my $self = shift;
  2992.     return $self->{_warning_count};
  2993. }
  2994.  
  2995. sub get_use_prefix {
  2996.     my $self = shift;
  2997.     return $self->{_use_prefix};
  2998. }
  2999.  
  3000. sub block_log_output {
  3001.     my $self = shift;
  3002.     $self->{_block_log_output} = 1;
  3003. }
  3004.  
  3005. sub unblock_log_output {
  3006.     my $self = shift;
  3007.     $self->{_block_log_output} = 0;
  3008. }
  3009.  
  3010. sub interrupt_logfile {
  3011.     my $self = shift;
  3012.     $self->{_use_prefix} = 0;
  3013.     $self->warning("\n");
  3014.     $self->write_logfile_entry( '#' x 24 . "  WARNING  " . '#' x 25 . "\n" );
  3015. }
  3016.  
  3017. sub resume_logfile {
  3018.     my $self = shift;
  3019.     $self->write_logfile_entry( '#' x 60 . "\n" );
  3020.     $self->{_use_prefix} = 1;
  3021. }
  3022.  
  3023. sub we_are_at_the_last_line {
  3024.     my $self = shift;
  3025.     unless ( $self->{_wrote_line_information_string} ) {
  3026.         $self->write_logfile_entry("Last line\n\n");
  3027.     }
  3028.     $self->{_at_end_of_file} = 1;
  3029. }
  3030.  
  3031. # record some stuff in case we go down in flames
  3032. sub black_box {
  3033.     my $self = shift;
  3034.     my ( $line_of_tokens, $output_line_number ) = @_;
  3035.     my $input_line        = $line_of_tokens->{_line_text};
  3036.     my $input_line_number = $line_of_tokens->{_line_number};
  3037.  
  3038.     # save line information in case we have to write a logfile message
  3039.     $self->{_line_of_tokens}                = $line_of_tokens;
  3040.     $self->{_output_line_number}            = $output_line_number;
  3041.     $self->{_wrote_line_information_string} = 0;
  3042.  
  3043.     my $last_input_line_written = $self->{_last_input_line_written};
  3044.     my $rOpts                   = $self->{_rOpts};
  3045.     if (
  3046.         (
  3047.             ( $input_line_number - $last_input_line_written ) >=
  3048.             $rOpts->{'logfile-gap'}
  3049.         )
  3050.         || ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ )
  3051.       )
  3052.     {
  3053.         my $rlevels                      = $line_of_tokens->{_rlevels};
  3054.         my $structural_indentation_level = $$rlevels[0];
  3055.         $self->{_last_input_line_written} = $input_line_number;
  3056.         ( my $out_str = $input_line ) =~ s/^\s*//;
  3057.         chomp $out_str;
  3058.  
  3059.         $out_str = ( '.' x $structural_indentation_level ) . $out_str;
  3060.  
  3061.         if ( length($out_str) > 35 ) {
  3062.             $out_str = substr( $out_str, 0, 35 ) . " ....";
  3063.         }
  3064.         $self->logfile_output( "", "$out_str\n" );
  3065.     }
  3066. }
  3067.  
  3068. sub write_logfile_entry {
  3069.     my $self = shift;
  3070.  
  3071.     # add leading >>> to avoid confusing error mesages and code
  3072.     $self->logfile_output( ">>>", "@_" );
  3073. }
  3074.  
  3075. sub write_column_headings {
  3076.     my $self = shift;
  3077.  
  3078.     $self->{_wrote_column_headings} = 1;
  3079.     my $routput_array = $self->{_output_array};
  3080.     push @{$routput_array}, <<EOM;
  3081. The nesting depths in the table below are at the start of the lines.
  3082. The indicated output line numbers are not always exact.
  3083. ci = levels of continuation indentation; bk = 1 if in BLOCK, 0 if not.
  3084.  
  3085. in:out indent c b  nesting   code + messages; (messages begin with >>>)
  3086. lines  levels i k            (code begins with one '.' per indent level)
  3087. ------  ----- - - --------   -------------------------------------------
  3088. EOM
  3089. }
  3090.  
  3091. sub make_line_information_string {
  3092.  
  3093.     # make columns of information when a logfile message needs to go out
  3094.     my $self                    = shift;
  3095.     my $line_of_tokens          = $self->{_line_of_tokens};
  3096.     my $input_line_number       = $line_of_tokens->{_line_number};
  3097.     my $line_information_string = "";
  3098.     if ($input_line_number) {
  3099.  
  3100.         my $output_line_number       = $self->{_output_line_number};
  3101.         my $brace_depth              = $line_of_tokens->{_curly_brace_depth};
  3102.         my $paren_depth              = $line_of_tokens->{_paren_depth};
  3103.         my $square_bracket_depth     = $line_of_tokens->{_square_bracket_depth};
  3104.         my $python_indentation_level =
  3105.           $line_of_tokens->{_python_indentation_level};
  3106.         my $rlevels         = $line_of_tokens->{_rlevels};
  3107.         my $rnesting_tokens = $line_of_tokens->{_rnesting_tokens};
  3108.         my $rci_levels      = $line_of_tokens->{_rci_levels};
  3109.         my $rnesting_blocks = $line_of_tokens->{_rnesting_blocks};
  3110.  
  3111.         my $structural_indentation_level = $$rlevels[0];
  3112.  
  3113.         $self->write_column_headings() unless $self->{_wrote_column_headings};
  3114.  
  3115.         # keep logfile columns aligned for scripts up to 999 lines;
  3116.         # for longer scripts it doesn't really matter
  3117.         my $extra_space = "";
  3118.         $extra_space .= ( $input_line_number < 10 ) ? "  "
  3119.           : ( $input_line_number < 100 ) ? " "
  3120.           : "";
  3121.         $extra_space .= ( $output_line_number < 10 ) ? "  "
  3122.           : ( $output_line_number < 100 ) ? " "
  3123.           : "";
  3124.  
  3125.         # there are 2 possible nesting strings:
  3126.         # the original which looks like this:  (0 [1 {2
  3127.         # the new one, which looks like this:  {{[
  3128.         # the new one is easier to read, and shows the order, but
  3129.         # could be arbitrarily long, so we use it unless it is too long
  3130.         my $nesting_string =
  3131.           "($paren_depth [$square_bracket_depth {$brace_depth";
  3132.         my $nesting_string_new = $$rnesting_tokens[0];
  3133.  
  3134.         my $ci_level = $$rci_levels[0];
  3135.         if ( $ci_level > 9 ) { $ci_level = '*' }
  3136.         my $bk = ( $$rnesting_blocks[0] =~ /1$/ ) ? '1' : '0';
  3137.  
  3138.         if ( length($nesting_string_new) <= 8 ) {
  3139.             $nesting_string =
  3140.               $nesting_string_new . " " x ( 8 - length($nesting_string_new) );
  3141.         }
  3142.         if ( $python_indentation_level < 0 ) { $python_indentation_level = 0 }
  3143.         $line_information_string =
  3144. "L$input_line_number:$output_line_number$extra_space i$python_indentation_level:$structural_indentation_level $ci_level $bk $nesting_string";
  3145.     }
  3146.     return $line_information_string;
  3147. }
  3148.  
  3149. sub logfile_output {
  3150.     my $self = shift;
  3151.     my ( $prompt, $msg ) = @_;
  3152.     return if ( $self->{_block_log_output} );
  3153.  
  3154.     my $routput_array = $self->{_output_array};
  3155.     if ( $self->{_at_end_of_file} || !$self->{_use_prefix} ) {
  3156.         push @{$routput_array}, "$msg";
  3157.     }
  3158.     else {
  3159.         my $line_information_string = $self->make_line_information_string();
  3160.         $self->{_wrote_line_information_string} = 1;
  3161.  
  3162.         if ($line_information_string) {
  3163.             push @{$routput_array}, "$line_information_string   $prompt$msg";
  3164.         }
  3165.         else {
  3166.             push @{$routput_array}, "$msg";
  3167.         }
  3168.     }
  3169. }
  3170.  
  3171. sub get_saw_brace_error {
  3172.     my $self = shift;
  3173.     return $self->{_saw_brace_error};
  3174. }
  3175.  
  3176. sub increment_brace_error {
  3177.     my $self = shift;
  3178.     $self->{_saw_brace_error}++;
  3179. }
  3180.  
  3181. sub brace_warning {
  3182.     my $self = shift;
  3183.     use constant BRACE_WARNING_LIMIT => 10;
  3184.     my $saw_brace_error = $self->{_saw_brace_error};
  3185.  
  3186.     if ( $saw_brace_error < BRACE_WARNING_LIMIT ) {
  3187.         $self->warning(@_);
  3188.     }
  3189.     $saw_brace_error++;
  3190.     $self->{_saw_brace_error} = $saw_brace_error;
  3191.  
  3192.     if ( $saw_brace_error == BRACE_WARNING_LIMIT ) {
  3193.         $self->warning("No further warnings of this type will be given\n");
  3194.     }
  3195. }
  3196.  
  3197. sub complain {
  3198.  
  3199.     # handle non-critical warning messages based on input flag
  3200.     my $self  = shift;
  3201.     my $rOpts = $self->{_rOpts};
  3202.  
  3203.     # these appear in .ERR output only if -w flag is used
  3204.     if ( $rOpts->{'warning-output'} ) {
  3205.         $self->warning(@_);
  3206.     }
  3207.  
  3208.     # otherwise, they go to the .LOG file
  3209.     else {
  3210.         $self->{_complaint_count}++;
  3211.         $self->write_logfile_entry(@_);
  3212.     }
  3213. }
  3214.  
  3215. sub warning {
  3216.  
  3217.     # report errors to .ERR file (or stdout)
  3218.     my $self = shift;
  3219.     use constant WARNING_LIMIT => 50;
  3220.  
  3221.     my $rOpts = $self->{_rOpts};
  3222.     unless ( $rOpts->{'quiet'} ) {
  3223.  
  3224.         my $warning_count = $self->{_warning_count};
  3225.         unless ($warning_count) {
  3226.             my $warning_file = $self->{_warning_file};
  3227.             my $fh_warnings;
  3228.             if ( $rOpts->{'standard-error-output'} ) {
  3229.                 $fh_warnings = *STDERR;
  3230.             }
  3231.             else {
  3232.                 ( $fh_warnings, my $filename ) =
  3233.                   Perl::Tidy::streamhandle( $warning_file, 'w' );
  3234.                 $fh_warnings or die ("couldn't open $filename $!\n");
  3235.                 warn "## Please see file $filename\n";
  3236.             }
  3237.             $self->{_fh_warnings} = $fh_warnings;
  3238.         }
  3239.  
  3240.         my $fh_warnings = $self->{_fh_warnings};
  3241.         if ( $warning_count < WARNING_LIMIT ) {
  3242.             if ( $self->get_use_prefix() > 0 ) {
  3243.                 my $input_line_number =
  3244.                   Perl::Tidy::Tokenizer::get_input_line_number();
  3245.                 print $fh_warnings "$input_line_number:\t@_";
  3246.                 $self->write_logfile_entry("WARNING: @_");
  3247.             }
  3248.             else {
  3249.                 print $fh_warnings @_;
  3250.                 $self->write_logfile_entry(@_);
  3251.             }
  3252.         }
  3253.         $warning_count++;
  3254.         $self->{_warning_count} = $warning_count;
  3255.  
  3256.         if ( $warning_count == WARNING_LIMIT ) {
  3257.             print $fh_warnings "No further warnings will be given";
  3258.         }
  3259.     }
  3260. }
  3261.  
  3262. # programming bug codes:
  3263. #   -1 = no bug
  3264. #    0 = maybe, not sure.
  3265. #    1 = definitely
  3266. sub report_possible_bug {
  3267.     my $self         = shift;
  3268.     my $saw_code_bug = $self->{_saw_code_bug};
  3269.     $self->{_saw_code_bug} = ( $saw_code_bug < 0 ) ? 0 : $saw_code_bug;
  3270. }
  3271.  
  3272. sub report_definite_bug {
  3273.     my $self = shift;
  3274.     $self->{_saw_code_bug} = 1;
  3275. }
  3276.  
  3277. sub ask_user_for_bug_report {
  3278.     my $self = shift;
  3279.  
  3280.     my ( $infile_syntax_ok, $formatter ) = @_;
  3281.     my $saw_code_bug = $self->{_saw_code_bug};
  3282.     if ( ( $saw_code_bug == 0 ) && ( $infile_syntax_ok == 1 ) ) {
  3283.         $self->warning(<<EOM);
  3284.  
  3285. You may have encountered a code bug in perltidy.  If you think so, and
  3286. the problem is not listed in the BUGS file at
  3287. http://perltidy.sourceforge.net, please report it so that it can be
  3288. corrected.  Include the smallest possible script which has the problem,
  3289. along with the .LOG file. See the manual pages for contact information.
  3290. Thank you!
  3291. EOM
  3292.  
  3293.     }
  3294.     elsif ( $saw_code_bug == 1 ) {
  3295.         if ( $self->{_saw_extrude} ) {
  3296.             $self->warning(<<EOM);
  3297. You may have encountered a bug in perltidy.  However, since you are
  3298. using the -extrude option, the problem may be with perl itself, which
  3299. has occasional parsing problems with this type of file.  If you believe
  3300. that the problem is with perltidy, and the problem is not listed in the
  3301. BUGS file at http://perltidy.sourceforge.net, please report it so that
  3302. it can be corrected.  Include the smallest possible script which has the
  3303. problem, along with the .LOG file. See the manual pages for contact
  3304. information.
  3305. Thank you!
  3306. EOM
  3307.         }
  3308.         else {
  3309.             $self->warning(<<EOM);
  3310.  
  3311. Oops, you seem to have encountered a bug in perltidy.  Please check the
  3312. BUGS file at http://perltidy.sourceforge.net.  If the problem is not
  3313. listed there, please report it so that it can be corrected.  Include the
  3314. smallest possible script which produces this message, along with the
  3315. .LOG file if appropriate.  See the manual pages for contact information.
  3316. Your efforts are appreciated.  
  3317. Thank you!
  3318. EOM
  3319.             my $added_semicolon_count = $formatter->get_added_semicolon_count();
  3320.             if ( $added_semicolon_count > 0 ) {
  3321.                 $self->warning(<<EOM);
  3322.  
  3323. The log file shows that perltidy added $added_semicolon_count semicolons.
  3324. Please rerun with -nasc to see if that is the cause of the syntax error.  Even
  3325. if that is the problem, please report it so that it can be fixed.
  3326. EOM
  3327.  
  3328.             }
  3329.         }
  3330.     }
  3331. }
  3332.  
  3333. sub finish {
  3334.  
  3335.     # called after all formatting to summarize errors
  3336.     my $self = shift;
  3337.     my ( $infile_syntax_ok, $formatter ) = @_;
  3338.  
  3339.     my $rOpts         = $self->{_rOpts};
  3340.     my $warning_count = $self->{_warning_count};
  3341.     my $saw_code_bug  = $self->{_saw_code_bug};
  3342.  
  3343.     my $save_logfile = ( $saw_code_bug == 0 && $infile_syntax_ok == 1 )
  3344.       || $saw_code_bug == 1
  3345.       || $rOpts->{'logfile'};
  3346.     my $log_file = $self->{_log_file};
  3347.     if ($warning_count) {
  3348.         if ($save_logfile) {
  3349.             $self->block_log_output();    # avoid echoing this to the logfile
  3350.             $self->warning(
  3351.                 "The logfile $log_file may contain useful information\n");
  3352.             $self->unblock_log_output();
  3353.         }
  3354.  
  3355.         if ( $self->{_complaint_count} > 0 ) {
  3356.             $self->warning(
  3357. "To see $self->{_complaint_count} non-critical warnings rerun with -w\n"
  3358.             );
  3359.         }
  3360.  
  3361.         if ( $self->{_saw_brace_error}
  3362.             && ( $rOpts->{'logfile-gap'} > 1 || !$save_logfile ) )
  3363.         {
  3364.             $self->warning("To save a full .LOG file rerun with -g\n");
  3365.         }
  3366.     }
  3367.     $self->ask_user_for_bug_report( $infile_syntax_ok, $formatter );
  3368.  
  3369.     if ($save_logfile) {
  3370.         my $log_file = $self->{_log_file};
  3371.         my ( $fh, $filename ) = Perl::Tidy::streamhandle( $log_file, 'w' );
  3372.         if ($fh) {
  3373.             my $routput_array = $self->{_output_array};
  3374.             foreach ( @{$routput_array} ) { $fh->print($_) }
  3375.             eval { $fh->close() };
  3376.         }
  3377.     }
  3378. }
  3379.  
  3380. #####################################################################
  3381. #
  3382. # The Perl::Tidy::DevNull class supplies a dummy print method
  3383. #
  3384. #####################################################################
  3385.  
  3386. package Perl::Tidy::DevNull;
  3387. sub new { return bless {}, $_[0] }
  3388. sub print { return }
  3389. sub close { return }
  3390.  
  3391. #####################################################################
  3392. #
  3393. # The Perl::Tidy::HtmlWriter class writes a copy of the input stream in html
  3394. #
  3395. #####################################################################
  3396.  
  3397. package Perl::Tidy::HtmlWriter;
  3398.  
  3399. use File::Basename;
  3400.  
  3401. # class variables
  3402. use vars qw{
  3403.   %html_color
  3404.   %html_bold
  3405.   %html_italic
  3406.   %token_short_names
  3407.   %short_to_long_names
  3408.   $rOpts
  3409.   $css_filename
  3410.   $css_linkname
  3411.   $missing_html_entities
  3412. };
  3413.  
  3414. # replace unsafe characters with HTML entity representation if HTML::Entities
  3415. # is available
  3416. { eval "use HTML::Entities"; $missing_html_entities = $@; }
  3417.  
  3418. sub new {
  3419.  
  3420.     my ( $class, $input_file, $html_file, $extension, $html_toc_extension,
  3421.         $html_src_extension )
  3422.       = @_;
  3423.  
  3424.     my $html_file_opened = 0;
  3425.     my $html_fh;
  3426.     ( $html_fh, my $html_filename ) =
  3427.       Perl::Tidy::streamhandle( $html_file, 'w' );
  3428.     unless ($html_fh) {
  3429.         warn("can't open $html_file: $!\n");
  3430.         return undef;
  3431.     }
  3432.     $html_file_opened = 1;
  3433.  
  3434.     if ( !$input_file || $input_file eq '-' || ref($input_file) ) {
  3435.         $input_file = "NONAME";
  3436.     }
  3437.  
  3438.     # write the table of contents to a string
  3439.     my $toc_string;
  3440.     my $html_toc_fh = Perl::Tidy::IOScalar->new( \$toc_string, 'w' );
  3441.  
  3442.     my $html_pre_fh;
  3443.     my @pre_string_stack;
  3444.     if ( $rOpts->{'html-pre-only'} ) {
  3445.  
  3446.         # pre section goes directly to the output stream
  3447.         $html_pre_fh = $html_fh;
  3448.         $html_pre_fh->print( <<"PRE_END");
  3449. <pre>
  3450. PRE_END
  3451.     }
  3452.     else {
  3453.  
  3454.         # pre section go out to a temporary string
  3455.         my $pre_string;
  3456.         $html_pre_fh = Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
  3457.         push @pre_string_stack, \$pre_string;
  3458.     }
  3459.  
  3460.     # pod text gets diverted if the 'pod2html' is used
  3461.     my $html_pod_fh;
  3462.     my $pod_string;
  3463.     if ( $rOpts->{'pod2html'} ) {
  3464.         if ( $rOpts->{'html-pre-only'} ) {
  3465.             undef $rOpts->{'pod2html'};
  3466.         }
  3467.         else {
  3468.             eval "use Pod::Html";
  3469.             if ($@) {
  3470.                 warn
  3471. "unable to find Pod::Html; cannot use pod2html\n-npod disables this message\n";
  3472.                 undef $rOpts->{'pod2html'};
  3473.             }
  3474.             else {
  3475.                 $html_pod_fh = Perl::Tidy::IOScalar->new( \$pod_string, 'w' );
  3476.             }
  3477.         }
  3478.     }
  3479.  
  3480.     my $toc_filename;
  3481.     my $src_filename;
  3482.     if ( $rOpts->{'frames'} ) {
  3483.         unless ($extension) {
  3484.             warn
  3485. "cannot use frames without a specified output extension; ignoring -frm\n";
  3486.             undef $rOpts->{'frames'};
  3487.         }
  3488.         else {
  3489.             $toc_filename = $input_file . $html_toc_extension . $extension;
  3490.             $src_filename = $input_file . $html_src_extension . $extension;
  3491.         }
  3492.     }
  3493.  
  3494.     # ----------------------------------------------------------
  3495.     # Output is now directed as follows:
  3496.     # html_toc_fh <-- table of contents items
  3497.     # html_pre_fh <-- the <pre> section of formatted code, except:
  3498.     # html_pod_fh <-- pod goes here with the pod2html option
  3499.     # ----------------------------------------------------------
  3500.  
  3501.     my $title = $rOpts->{'title'};
  3502.     unless ($title) {
  3503.         ( $title, my $path ) = fileparse($input_file);
  3504.     }
  3505.     my $toc_item_count = 0;
  3506.     my $in_toc_package = "";
  3507.     my $last_level     = 0;
  3508.     bless {
  3509.         _input_file        => $input_file,          # name of input file
  3510.         _title             => $title,               # title, unescaped
  3511.         _html_file         => $html_file,           # name of .html output file
  3512.         _toc_filename      => $toc_filename,        # for frames option
  3513.         _src_filename      => $src_filename,        # for frames option
  3514.         _html_file_opened  => $html_file_opened,    # a flag
  3515.         _html_fh           => $html_fh,             # the output stream
  3516.         _html_pre_fh       => $html_pre_fh,         # pre section goes here
  3517.         _rpre_string_stack => \@pre_string_stack,   # stack of pre sections
  3518.         _html_pod_fh       => $html_pod_fh,         # pod goes here if pod2html
  3519.         _rpod_string       => \$pod_string,         # string holding pod
  3520.         _pod_cut_count     => 0,                    # how many =cut's?
  3521.         _html_toc_fh       => $html_toc_fh,         # fh for table of contents
  3522.         _rtoc_string       => \$toc_string,         # string holding toc
  3523.         _rtoc_item_count   => \$toc_item_count,     # how many toc items
  3524.         _rin_toc_package   => \$in_toc_package,     # package name
  3525.         _rtoc_name_count   => {},                   # hash to track unique names
  3526.         _rpackage_stack    => [],                   # stack to check for package
  3527.                                                     # name changes
  3528.         _rlast_level       => \$last_level,         # brace indentation level
  3529.     }, $class;
  3530. }
  3531.  
  3532. sub add_toc_item {
  3533.  
  3534.     # Add an item to the html table of contents.
  3535.     # This is called even if no table of contents is written,
  3536.     # because we still want to put the anchors in the <pre> text.
  3537.     # We are given an anchor name and its type; types are:
  3538.     #      'package', 'sub', '__END__', '__DATA__', 'EOF'
  3539.     # There must be an 'EOF' call at the end to wrap things up.
  3540.     my $self = shift;
  3541.     my ( $name, $type ) = @_;
  3542.     my $html_toc_fh     = $self->{_html_toc_fh};
  3543.     my $html_pre_fh     = $self->{_html_pre_fh};
  3544.     my $rtoc_name_count = $self->{_rtoc_name_count};
  3545.     my $rtoc_item_count = $self->{_rtoc_item_count};
  3546.     my $rlast_level     = $self->{_rlast_level};
  3547.     my $rin_toc_package = $self->{_rin_toc_package};
  3548.     my $rpackage_stack  = $self->{_rpackage_stack};
  3549.  
  3550.     # packages contain sublists of subs, so to avoid errors all package
  3551.     # items are written and finished with the following routines
  3552.     my $end_package_list = sub {
  3553.         if ($$rin_toc_package) {
  3554.             $html_toc_fh->print("</ul>\n</li>\n");
  3555.             $$rin_toc_package = "";
  3556.         }
  3557.     };
  3558.  
  3559.     my $start_package_list = sub {
  3560.         my ( $unique_name, $package ) = @_;
  3561.         if ($$rin_toc_package) { $end_package_list->() }
  3562.         $html_toc_fh->print(<<EOM);
  3563. <li><a href=\"#$unique_name\">package $package</a>
  3564. <ul>
  3565. EOM
  3566.         $$rin_toc_package = $package;
  3567.     };
  3568.  
  3569.     # start the table of contents on the first item
  3570.     unless ($$rtoc_item_count) {
  3571.  
  3572.         # but just quit if we hit EOF without any other entries
  3573.         # in this case, there will be no toc
  3574.         return if ( $type eq 'EOF' );
  3575.         $html_toc_fh->print( <<"TOC_END");
  3576. <!-- BEGIN CODE INDEX --><a name="code-index"></a>
  3577. <ul>
  3578. TOC_END
  3579.     }
  3580.     $$rtoc_item_count++;
  3581.  
  3582.     # make a unique anchor name for this location:
  3583.     #   - packages get a 'package-' prefix
  3584.     #   - subs use their names
  3585.     my $unique_name = $name;
  3586.     if ( $type eq 'package' ) { $unique_name = "package-$name" }
  3587.  
  3588.     # append '-1', '-2', etc if necessary to make unique; this will
  3589.     # be unique because subs and packages cannot have a '-'
  3590.     if ( my $count = $rtoc_name_count->{ lc $unique_name }++ ) {
  3591.         $unique_name .= "-$count";
  3592.     }
  3593.  
  3594.     #   - all names get terminal '-' if pod2html is used, to avoid
  3595.     #     conflicts with anchor names created by pod2html
  3596.     if ( $rOpts->{'pod2html'} ) { $unique_name .= '-' }
  3597.  
  3598.     # start/stop lists of subs
  3599.     if ( $type eq 'sub' ) {
  3600.         my $package = $rpackage_stack->[$$rlast_level];
  3601.         unless ($package) { $package = 'main' }
  3602.  
  3603.         # if we're already in a package/sub list, be sure its the right
  3604.         # package or else close it
  3605.         if ( $$rin_toc_package && $$rin_toc_package ne $package ) {
  3606.             $end_package_list->();
  3607.         }
  3608.  
  3609.         # start a package/sub list if necessary
  3610.         unless ($$rin_toc_package) {
  3611.             $start_package_list->( $unique_name, $package );
  3612.         }
  3613.     }
  3614.  
  3615.     # now write an entry in the toc for this item
  3616.     if ( $type eq 'package' ) {
  3617.         $start_package_list->( $unique_name, $name );
  3618.     }
  3619.     elsif ( $type eq 'sub' ) {
  3620.         $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
  3621.     }
  3622.     else {
  3623.         $end_package_list->();
  3624.         $html_toc_fh->print("<li><a href=\"#$unique_name\">$name</a></li>\n");
  3625.     }
  3626.  
  3627.     # write the anchor in the <pre> section
  3628.     $html_pre_fh->print("<a name=\"$unique_name\"></a>");
  3629.  
  3630.     # end the table of contents, if any, on the end of file
  3631.     if ( $type eq 'EOF' ) {
  3632.         $html_toc_fh->print( <<"TOC_END");
  3633. </ul>
  3634. <!-- END CODE INDEX -->
  3635. TOC_END
  3636.     }
  3637. }
  3638.  
  3639. BEGIN {
  3640.  
  3641.     # This is the official list of tokens which may be identified by the
  3642.     # user.  Long names are used as getopt keys.  Short names are
  3643.     # convenient short abbreviations for specifying input.  Short names
  3644.     # somewhat resemble token type characters, but are often different
  3645.     # because they may only be alphanumeric, to allow command line
  3646.     # input.  Also, note that because of case insensitivity of html,
  3647.     # this table must be in a single case only (I've chosen to use all
  3648.     # lower case).
  3649.     # When adding NEW_TOKENS: update this hash table
  3650.     # short names => long names
  3651.     %short_to_long_names = (
  3652.         'n'  => 'numeric',
  3653.         'p'  => 'paren',
  3654.         'q'  => 'quote',
  3655.         's'  => 'structure',
  3656.         'c'  => 'comment',
  3657.         'v'  => 'v-string',
  3658.         'cm' => 'comma',
  3659.         'w'  => 'bareword',
  3660.         'co' => 'colon',
  3661.         'pu' => 'punctuation',
  3662.         'i'  => 'identifier',
  3663.         'j'  => 'label',
  3664.         'h'  => 'here-doc-target',
  3665.         'hh' => 'here-doc-text',
  3666.         'k'  => 'keyword',
  3667.         'sc' => 'semicolon',
  3668.         'm'  => 'subroutine',
  3669.         'pd' => 'pod-text',
  3670.     );
  3671.  
  3672.     # Now we have to map actual token types into one of the above short
  3673.     # names; any token types not mapped will get 'punctuation'
  3674.     # properties.
  3675.  
  3676.     # The values of this hash table correspond to the keys of the
  3677.     # previous hash table.
  3678.     # The keys of this hash table are token types and can be seen
  3679.     # by running with --dump-token-types (-dtt).
  3680.  
  3681.     # When adding NEW_TOKENS: update this hash table
  3682.     # $type => $short_name
  3683.     %token_short_names = (
  3684.         '#'  => 'c',
  3685.         'n'  => 'n',
  3686.         'v'  => 'v',
  3687.         'k'  => 'k',
  3688.         'F'  => 'k',
  3689.         'Q'  => 'q',
  3690.         'q'  => 'q',
  3691.         'J'  => 'j',
  3692.         'j'  => 'j',
  3693.         'h'  => 'h',
  3694.         'H'  => 'hh',
  3695.         'w'  => 'w',
  3696.         ','  => 'cm',
  3697.         '=>' => 'cm',
  3698.         ';'  => 'sc',
  3699.         ':'  => 'co',
  3700.         'f'  => 'sc',
  3701.         '('  => 'p',
  3702.         ')'  => 'p',
  3703.         'M'  => 'm',
  3704.         'P'  => 'pd',
  3705.         'A'  => 'co',
  3706.     );
  3707.  
  3708.     # These token types will all be called identifiers for now
  3709.     # FIXME: need to separate user defined modules as separate type
  3710.     my @identifier = qw" i t U C Y Z G :: ";
  3711.     @token_short_names{@identifier} = ('i') x scalar(@identifier);
  3712.  
  3713.     # These token types will be called 'structure'
  3714.     my @structure = qw" { } ";
  3715.     @token_short_names{@structure} = ('s') x scalar(@structure);
  3716.  
  3717.     # OLD NOTES: save for reference
  3718.     # Any of these could be added later if it would be useful.
  3719.     # For now, they will by default become punctuation
  3720.     #    my @list = qw" L R [ ] ";
  3721.     #    @token_long_names{@list} = ('non-structure') x scalar(@list);
  3722.     #
  3723.     #    my @list = qw"
  3724.     #      / /= * *= ** **= + += - -= % %= = ++ -- << <<= >> >>= pp p m mm
  3725.     #      ";
  3726.     #    @token_long_names{@list} = ('math') x scalar(@list);
  3727.     #
  3728.     #    my @list = qw" & &= ~ ~= ^ ^= | |= ";
  3729.     #    @token_long_names{@list} = ('bit') x scalar(@list);
  3730.     #
  3731.     #    my @list = qw" == != < > <= <=> ";
  3732.     #    @token_long_names{@list} = ('numerical-comparison') x scalar(@list);
  3733.     #
  3734.     #    my @list = qw" && || ! &&= ||= ";
  3735.     #    @token_long_names{@list} = ('logical') x scalar(@list);
  3736.     #
  3737.     #    my @list = qw" . .= =~ !~ x x= ";
  3738.     #    @token_long_names{@list} = ('string-operators') x scalar(@list);
  3739.     #
  3740.     #    # Incomplete..
  3741.     #    my @list = qw" .. -> <> ... \ ? ";
  3742.     #    @token_long_names{@list} = ('misc-operators') x scalar(@list);
  3743.  
  3744. }
  3745.  
  3746. sub make_getopt_long_names {
  3747.     my $class = shift;
  3748.     my ($rgetopt_names) = @_;
  3749.     while ( my ( $short_name, $name ) = each %short_to_long_names ) {
  3750.         push @$rgetopt_names, "html-color-$name=s";
  3751.         push @$rgetopt_names, "html-italic-$name!";
  3752.         push @$rgetopt_names, "html-bold-$name!";
  3753.     }
  3754.     push @$rgetopt_names, "html-color-background=s";
  3755.     push @$rgetopt_names, "html-linked-style-sheet=s";
  3756.     push @$rgetopt_names, "nohtml-style-sheets";
  3757.     push @$rgetopt_names, "html-pre-only";
  3758.     push @$rgetopt_names, "html-line-numbers";
  3759.     push @$rgetopt_names, "stylesheet";
  3760.     push @$rgetopt_names, "html-table-of-contents!";
  3761.     push @$rgetopt_names, "pod2html!";
  3762.     push @$rgetopt_names, "frames!";
  3763.     push @$rgetopt_names, "html-toc-extension=s";
  3764.     push @$rgetopt_names, "html-src-extension=s";
  3765.  
  3766.     # Pod::Html parameters:
  3767.     push @$rgetopt_names, "backlink=s";
  3768.     push @$rgetopt_names, "cachedir=s";
  3769.     push @$rgetopt_names, "htmlroot=s";
  3770.     push @$rgetopt_names, "libpods=s";
  3771.     push @$rgetopt_names, "podpath=s";
  3772.     push @$rgetopt_names, "podroot=s";
  3773.     push @$rgetopt_names, "title=s";
  3774.  
  3775.     # Pod::Html parameters with leading 'pod' which will be removed
  3776.     # before the call to Pod::Html
  3777.     push @$rgetopt_names, "podquiet!";
  3778.     push @$rgetopt_names, "podverbose!";
  3779.     push @$rgetopt_names, "podrecurse!";
  3780.     push @$rgetopt_names, "podflush";
  3781.     push @$rgetopt_names, "podheader!";
  3782.     push @$rgetopt_names, "podindex!";
  3783. }
  3784.  
  3785. sub make_abbreviated_names {
  3786.  
  3787.     # We're appending things like this to the expansion list:
  3788.     #      'hcc'    => [qw(html-color-comment)],
  3789.     #      'hck'    => [qw(html-color-keyword)],
  3790.     #  etc
  3791.     my $class = shift;
  3792.     my ($rexpansion) = @_;
  3793.  
  3794.     # abbreviations for color/bold/italic properties
  3795.     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
  3796.         ${$rexpansion}{"hc$short_name"}  = ["html-color-$long_name"];
  3797.         ${$rexpansion}{"hb$short_name"}  = ["html-bold-$long_name"];
  3798.         ${$rexpansion}{"hi$short_name"}  = ["html-italic-$long_name"];
  3799.         ${$rexpansion}{"nhb$short_name"} = ["nohtml-bold-$long_name"];
  3800.         ${$rexpansion}{"nhi$short_name"} = ["nohtml-italic-$long_name"];
  3801.     }
  3802.  
  3803.     # abbreviations for all other html options
  3804.     ${$rexpansion}{"hcbg"} = ["html-color-background"];
  3805.     ${$rexpansion}{"pre"}  = ["html-pre-only"];
  3806.     ${$rexpansion}{"toc"}  = ["html-table-of-contents"];
  3807.     ${$rexpansion}{"ntoc"} = ["nohtml-table-of-contents"];
  3808.     ${$rexpansion}{"nnn"}  = ["html-line-numbers"];
  3809.     ${$rexpansion}{"css"}  = ["html-linked-style-sheet"];
  3810.     ${$rexpansion}{"nss"}  = ["nohtml-style-sheets"];
  3811.     ${$rexpansion}{"ss"}   = ["stylesheet"];
  3812.     ${$rexpansion}{"pod"}  = ["pod2html"];
  3813.     ${$rexpansion}{"npod"} = ["nopod2html"];
  3814.     ${$rexpansion}{"frm"}  = ["frames"];
  3815.     ${$rexpansion}{"nfrm"} = ["noframes"];
  3816.     ${$rexpansion}{"text"} = ["html-toc-extension"];
  3817.     ${$rexpansion}{"sext"} = ["html-src-extension"];
  3818. }
  3819.  
  3820. sub check_options {
  3821.  
  3822.     # This will be called once after options have been parsed
  3823.     my $class = shift;
  3824.     $rOpts = shift;
  3825.  
  3826.     # X11 color names for default settings that seemed to look ok
  3827.     # (these color names are only used for programming clarity; the hex
  3828.     # numbers are actually written)
  3829.     use constant ForestGreen   => "#228B22";
  3830.     use constant SaddleBrown   => "#8B4513";
  3831.     use constant magenta4      => "#8B008B";
  3832.     use constant IndianRed3    => "#CD5555";
  3833.     use constant DeepSkyBlue4  => "#00688B";
  3834.     use constant MediumOrchid3 => "#B452CD";
  3835.     use constant black         => "#000000";
  3836.     use constant white         => "#FFFFFF";
  3837.     use constant red           => "#FF0000";
  3838.  
  3839.     # set default color, bold, italic properties
  3840.     # anything not listed here will be given the default (punctuation) color --
  3841.     # these types currently not listed and get default: ws pu s sc cm co p
  3842.     # When adding NEW_TOKENS: add an entry here if you don't want defaults
  3843.  
  3844.     # set_default_properties( $short_name, default_color, bold?, italic? );
  3845.     set_default_properties( 'c',  ForestGreen,   0, 0 );
  3846.     set_default_properties( 'pd', ForestGreen,   0, 1 );
  3847.     set_default_properties( 'k',  magenta4,      1, 0 );    # was SaddleBrown
  3848.     set_default_properties( 'q',  IndianRed3,    0, 0 );
  3849.     set_default_properties( 'hh', IndianRed3,    0, 1 );
  3850.     set_default_properties( 'h',  IndianRed3,    1, 0 );
  3851.     set_default_properties( 'i',  DeepSkyBlue4,  0, 0 );
  3852.     set_default_properties( 'w',  black,         0, 0 );
  3853.     set_default_properties( 'n',  MediumOrchid3, 0, 0 );
  3854.     set_default_properties( 'v',  MediumOrchid3, 0, 0 );
  3855.     set_default_properties( 'j',  IndianRed3,    1, 0 );
  3856.     set_default_properties( 'm',  red,           1, 0 );
  3857.  
  3858.     set_default_color( 'html-color-background',  white );
  3859.     set_default_color( 'html-color-punctuation', black );
  3860.  
  3861.     # setup property lookup tables for tokens based on their short names
  3862.     # every token type has a short name, and will use these tables
  3863.     # to do the html markup
  3864.     while ( my ( $short_name, $long_name ) = each %short_to_long_names ) {
  3865.         $html_color{$short_name}  = $rOpts->{"html-color-$long_name"};
  3866.         $html_bold{$short_name}   = $rOpts->{"html-bold-$long_name"};
  3867.         $html_italic{$short_name} = $rOpts->{"html-italic-$long_name"};
  3868.     }
  3869.  
  3870.     # write style sheet to STDOUT and die if requested
  3871.     if ( defined( $rOpts->{'stylesheet'} ) ) {
  3872.         write_style_sheet_file('-');
  3873.         exit 1;
  3874.     }
  3875.  
  3876.     # make sure user gives a file name after -css
  3877.     if ( defined( $rOpts->{'html-linked-style-sheet'} ) ) {
  3878.         $css_linkname = $rOpts->{'html-linked-style-sheet'};
  3879.         if ( $css_linkname =~ /^-/ ) {
  3880.             die "You must specify a valid filename after -css\n";
  3881.         }
  3882.     }
  3883.  
  3884.     # check for conflict
  3885.     if ( $css_linkname && $rOpts->{'nohtml-style-sheets'} ) {
  3886.         $rOpts->{'nohtml-style-sheets'} = 0;
  3887.         warning("You can't specify both -css and -nss; -nss ignored\n");
  3888.     }
  3889.  
  3890.     # write a style sheet file if necessary
  3891.     if ($css_linkname) {
  3892.  
  3893.         # if the selected filename exists, don't write, because user may
  3894.         # have done some work by hand to create it; use backup name instead
  3895.         # Also, this will avoid a potential disaster in which the user
  3896.         # forgets to specify the style sheet, like this:
  3897.         #    perltidy -html -css myfile1.pl myfile2.pl
  3898.         # This would cause myfile1.pl to parsed as the style sheet by GetOpts
  3899.         my $css_filename = $css_linkname;
  3900.         unless ( -e $css_filename ) {
  3901.             write_style_sheet_file($css_filename);
  3902.         }
  3903.     }
  3904. }
  3905.  
  3906. sub write_style_sheet_file {
  3907.  
  3908.     my $css_filename = shift;
  3909.     my $fh;
  3910.     unless ( $fh = IO::File->new("> $css_filename") ) {
  3911.         die "can't open $css_filename: $!\n";
  3912.     }
  3913.     write_style_sheet_data($fh);
  3914.     eval { $fh->close };
  3915. }
  3916.  
  3917. sub write_style_sheet_data {
  3918.  
  3919.     # write the style sheet data to an open file handle
  3920.     my $fh = shift;
  3921.  
  3922.     my $bg_color   = $rOpts->{'html-color-background'};
  3923.     my $text_color = $rOpts->{'html-color-punctuation'};
  3924.  
  3925.     # pre-bgcolor is new, and may not be defined
  3926.     my $pre_bg_color = $rOpts->{'html-pre-color-background'};
  3927.     $pre_bg_color = $bg_color unless $pre_bg_color;
  3928.  
  3929.     $fh->print(<<"EOM");
  3930. /* default style sheet generated by perltidy */
  3931. body {background: $bg_color; color: $text_color}
  3932. pre { color: $text_color; 
  3933.       background: $pre_bg_color;
  3934.       font-family: courier;
  3935.     } 
  3936.  
  3937. EOM
  3938.  
  3939.     foreach my $short_name ( sort keys %short_to_long_names ) {
  3940.         my $long_name = $short_to_long_names{$short_name};
  3941.  
  3942.         my $abbrev = '.' . $short_name;
  3943.         if ( length($short_name) == 1 ) { $abbrev .= ' ' }    # for alignment
  3944.         my $color = $html_color{$short_name};
  3945.         if ( !defined($color) ) { $color = $text_color }
  3946.         $fh->print("$abbrev \{ color: $color;");
  3947.  
  3948.         if ( $html_bold{$short_name} ) {
  3949.             $fh->print(" font-weight:bold;");
  3950.         }
  3951.  
  3952.         if ( $html_italic{$short_name} ) {
  3953.             $fh->print(" font-style:italic;");
  3954.         }
  3955.         $fh->print("} /* $long_name */\n");
  3956.     }
  3957. }
  3958.  
  3959. sub set_default_color {
  3960.  
  3961.     # make sure that options hash $rOpts->{$key} contains a valid color
  3962.     my ( $key, $color ) = @_;
  3963.     if ( $rOpts->{$key} ) { $color = $rOpts->{$key} }
  3964.     $rOpts->{$key} = check_RGB($color);
  3965. }
  3966.  
  3967. sub check_RGB {
  3968.  
  3969.     # if color is a 6 digit hex RGB value, prepend a #, otherwise
  3970.     # assume that it is a valid ascii color name
  3971.     my ($color) = @_;
  3972.     if ( $color =~ /^[0-9a-fA-F]{6,6}$/ ) { $color = "#$color" }
  3973.     return $color;
  3974. }
  3975.  
  3976. sub set_default_properties {
  3977.     my ( $short_name, $color, $bold, $italic ) = @_;
  3978.  
  3979.     set_default_color( "html-color-$short_to_long_names{$short_name}", $color );
  3980.     my $key;
  3981.     $key = "html-bold-$short_to_long_names{$short_name}";
  3982.     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $bold;
  3983.     $key = "html-italic-$short_to_long_names{$short_name}";
  3984.     $rOpts->{$key} = ( defined $rOpts->{$key} ) ? $rOpts->{$key} : $italic;
  3985. }
  3986.  
  3987. sub pod_to_html {
  3988.  
  3989.     # Use Pod::Html to process the pod and make the page
  3990.     # then merge the perltidy code sections into it.
  3991.     # return 1 if success, 0 otherwise
  3992.     my $self = shift;
  3993.     my ( $pod_string, $css_string, $toc_string, $rpre_string_stack ) = @_;
  3994.     my $input_file   = $self->{_input_file};
  3995.     my $title        = $self->{_title};
  3996.     my $success_flag = 0;
  3997.  
  3998.     # don't try to use pod2html if no pod
  3999.     unless ($pod_string) {
  4000.         return $success_flag;
  4001.     }
  4002.  
  4003.     # Pod::Html requires a real temporary filename
  4004.     # If we are making a frame, we have a name available
  4005.     # Otherwise, we have to fine one
  4006.     my $tmpfile;
  4007.     if ( $rOpts->{'frames'} ) {
  4008.         $tmpfile = $self->{_toc_filename};
  4009.     }
  4010.     else {
  4011.         $tmpfile = Perl::Tidy::make_temporary_filename();
  4012.     }
  4013.     my $fh_tmp = IO::File->new( $tmpfile, 'w' );
  4014.     unless ($fh_tmp) {
  4015.         warn "unable to open temporary file $tmpfile; cannot use pod2html\n";
  4016.         return $success_flag;
  4017.     }
  4018.  
  4019.     #------------------------------------------------------------------
  4020.     # Warning: a temporary file is open; we have to clean up if
  4021.     # things go bad.  From here on all returns should be by going to
  4022.     # RETURN so that the temporary file gets unlinked.
  4023.     #------------------------------------------------------------------
  4024.  
  4025.     # write the pod text to the temporary file
  4026.     $fh_tmp->print($pod_string);
  4027.     $fh_tmp->close();
  4028.  
  4029.     # Hand off the pod to pod2html.
  4030.     # Note that we can use the same temporary filename for input and output
  4031.     # because of the way pod2html works.
  4032.     {
  4033.  
  4034.         my @args;
  4035.         push @args, "--infile=$tmpfile", "--outfile=$tmpfile", "--title=$title";
  4036.         my $kw;
  4037.  
  4038.         # Flags with string args:
  4039.         # "backlink=s", "cachedir=s", "htmlroot=s", "libpods=s",
  4040.         # "podpath=s", "podroot=s"
  4041.         # Note: -css=s is handled by perltidy itself
  4042.         foreach $kw (qw(backlink cachedir htmlroot libpods podpath podroot)) {
  4043.             if ( $rOpts->{$kw} ) { push @args, "--$kw=$rOpts->{$kw}" }
  4044.         }
  4045.  
  4046.         # Toggle switches; these have extra leading 'pod'
  4047.         # "header!", "index!", "recurse!", "quiet!", "verbose!"
  4048.         foreach $kw (qw(podheader podindex podrecurse podquiet podverbose)) {
  4049.             my $kwd = $kw;    # allows us to strip 'pod'
  4050.             if ( $rOpts->{$kw} ) { $kwd =~ s/^pod//; push @args, "--$kwd" }
  4051.             elsif ( defined( $rOpts->{$kw} ) ) {
  4052.                 $kwd =~ s/^pod//;
  4053.                 push @args, "--no$kwd";
  4054.             }
  4055.         }
  4056.  
  4057.         # "flush",
  4058.         $kw = 'podflush';
  4059.         if ( $rOpts->{$kw} ) { $kw =~ s/^pod//; push @args, "--$kw" }
  4060.  
  4061.         # Must clean up if pod2html dies (it can);
  4062.         # Be careful not to overwrite callers __DIE__ routine
  4063.         local $SIG{__DIE__} = sub {
  4064.             print $_[0];
  4065.             unlink $tmpfile if -e $tmpfile;
  4066.             exit 1;
  4067.         };
  4068.  
  4069.         pod2html(@args);
  4070.     }
  4071.     $fh_tmp = IO::File->new( $tmpfile, 'r' );
  4072.     unless ($fh_tmp) {
  4073.  
  4074.         # this error shouldn't happen ... we just used this filename
  4075.         warn "unable to open temporary file $tmpfile; cannot use pod2html\n";
  4076.         goto RETURN;
  4077.     }
  4078.  
  4079.     my $html_fh = $self->{_html_fh};
  4080.     my @toc;
  4081.     my $in_toc;
  4082.     my $no_print;
  4083.  
  4084.     # This routine will write the html selectively and store the toc
  4085.     my $html_print = sub {
  4086.         foreach (@_) {
  4087.             $html_fh->print($_) unless ($no_print);
  4088.             if ($in_toc) { push @toc, $_ }
  4089.         }
  4090.     };
  4091.  
  4092.     # loop over lines of html output from pod2html and merge in
  4093.     # the necessary perltidy html sections
  4094.     my ( $saw_body, $saw_index, $saw_body_end );
  4095.     while ( my $line = $fh_tmp->getline() ) {
  4096.  
  4097.         if ( $line =~ /^\s*<html>\s*$/i ) {
  4098.             my $date = localtime;
  4099.             $html_print->("<!-- Generated by perltidy on $date -->\n");
  4100.             $html_print->($line);
  4101.         }
  4102.  
  4103.         # Copy the perltidy css, if any, after <body> tag
  4104.         elsif ( $line =~ /^\s*<body>\s*$/i ) {
  4105.             $saw_body = 1;
  4106.             $html_print->($css_string) if $css_string;
  4107.             $html_print->($line);
  4108.  
  4109.             # add a top anchor and heading
  4110.             $html_print->("<a name=\"-top-\"></a>\n");
  4111.             $title = escape_html($title);
  4112.             $html_print->("<h1>$title</h1>\n");
  4113.         }
  4114.         elsif ( $line =~ /^\s*<!-- INDEX BEGIN -->\s*$/i ) {
  4115.             $in_toc = 1;
  4116.  
  4117.             # when frames are used, an extra table of contents in the
  4118.             # contents panel is confusing, so don't print it
  4119.             $no_print = $rOpts->{'frames'}
  4120.               || !$rOpts->{'html-table-of-contents'};
  4121.             $html_print->("<h2>Doc Index:</h2>\n") if $rOpts->{'frames'};
  4122.             $html_print->($line);
  4123.         }
  4124.  
  4125.         # Copy the perltidy toc, if any, after the Pod::Html toc
  4126.         elsif ( $line =~ /^\s*<!-- INDEX END -->\s*$/i ) {
  4127.             $saw_index = 1;
  4128.             $html_print->($line);
  4129.             if ($toc_string) {
  4130.                 $html_print->("<hr />\n") if $rOpts->{'frames'};
  4131.                 $html_print->("<h2>Code Index:</h2>\n");
  4132.                 my @toc = map { $_ .= "\n" } split /\n/, $toc_string;
  4133.                 $html_print->(@toc);
  4134.             }
  4135.             $in_toc   = 0;
  4136.             $no_print = 0;
  4137.         }
  4138.  
  4139.         # Copy one perltidy section after each marker
  4140.         elsif ( $line =~ /<!-- pERLTIDY sECTION -->(.*)$/ ) {
  4141.             $line = $1;
  4142.  
  4143.             # Only mix code and pod sections if we saw multiple =cut's.
  4144.             # Otherwise, we'll put the pod out first and then
  4145.             # the code, because it's less confusing.
  4146.             if ( $self->{_pod_cut_count} > 1 ) {
  4147.                 my $rpre_string = shift (@$rpre_string_stack);
  4148.                 if ($$rpre_string) {
  4149.                     $html_print->('<pre>');
  4150.                     $html_print->($$rpre_string);
  4151.                     $html_print->('</pre>');
  4152.                 }
  4153.                 else {
  4154.  
  4155.                     # shouldn't happen: we stored a string before writing
  4156.                     # each marker.
  4157.                     warn
  4158. "Problem merging html stream with pod2html; order may be wrong\n";
  4159.                 }
  4160.  
  4161.                 # The rest of the comment has an <hr>; we
  4162.                 # only want it if we are printing some code.
  4163.                 $html_print->($line);
  4164.             }
  4165.         }
  4166.  
  4167.         # Copy any remaining code section before the </body> tag
  4168.         elsif ( $line =~ /^\s*<\/body>\s*$/i ) {
  4169.             $saw_body_end = 1;
  4170.             if (@$rpre_string_stack) {
  4171.                 unless ( $self->{_pod_cut_count} > 1 ) {
  4172.                     $html_print->('<hr />');
  4173.                 }
  4174.                 while ( my $rpre_string = shift (@$rpre_string_stack) ) {
  4175.                     $html_print->('<pre>');
  4176.                     $html_print->($$rpre_string);
  4177.                     $html_print->('</pre>');
  4178.                 }
  4179.             }
  4180.             $html_print->($line);
  4181.         }
  4182.         else {
  4183.             $html_print->($line);
  4184.         }
  4185.     }
  4186.  
  4187.     $success_flag = 1;
  4188.     unless ($saw_body) {
  4189.         warn "Did not see <body> in pod2html output\n";
  4190.         $success_flag = 0;
  4191.     }
  4192.     unless ($saw_body_end) {
  4193.         warn "Did not see </body> in pod2html output\n";
  4194.         $success_flag = 0;
  4195.     }
  4196.     unless ($saw_index) {
  4197.         warn "Did not find INDEX END in pod2html output\n";
  4198.         $success_flag = 0;
  4199.     }
  4200.  
  4201.   RETURN:
  4202.     eval { $html_fh->close() };
  4203.  
  4204.     # note that we have to unlink tmpfile before making frames
  4205.     # because the tmpfile may be one of the names used for frames
  4206.     unlink $tmpfile if -e $tmpfile;
  4207.     if ( $success_flag && $rOpts->{'frames'} ) {
  4208.         $self->make_frame( \@toc );
  4209.     }
  4210.     return $success_flag;
  4211. }
  4212.  
  4213. sub make_frame {
  4214.  
  4215.     # Make a frame with table of contents in the left panel
  4216.     # and the text in the right panel.
  4217.     # On entry:
  4218.     #  $html_filename contains the no-frames html output
  4219.     #  $rtoc is a reference to an array with the table of contents
  4220.     my $self = shift;
  4221.     my ($rtoc) = @_;
  4222.     my $input_file    = $self->{_input_file};
  4223.     my $html_filename = $self->{_html_file};
  4224.     my $toc_filename  = $self->{_toc_filename};
  4225.     my $src_filename  = $self->{_src_filename};
  4226.     my $title         = $self->{_title};
  4227.     $title = escape_html($title);
  4228.  
  4229.     # FUTURE input parameter:
  4230.     my $top_basename = "";
  4231.  
  4232.     # We need to produce 3 html files:
  4233.     # 1. - the table of contents
  4234.     # 2. - the contents (source code) itself
  4235.     # 3. - the frame which contains them
  4236.  
  4237.     # get basenames for relative links
  4238.     my ( $toc_basename, $toc_path ) = fileparse($toc_filename);
  4239.     my ( $src_basename, $src_path ) = fileparse($src_filename);
  4240.  
  4241.     # 1. Make the table of contents panel, with appropriate changes
  4242.     # to the anchor names
  4243.     my $src_frame_name = 'SRC';
  4244.     my $first_anchor   =
  4245.       write_toc_html( $title, $toc_filename, $src_basename, $rtoc,
  4246.         $src_frame_name );
  4247.  
  4248.     # 2. The current .html filename is renamed to be the contents panel
  4249.     rename( $html_filename, $src_filename )
  4250.       or die "Cannot rename $html_filename to $src_filename:$!\n";
  4251.  
  4252.     # 3. Then use the original html filename for the frame
  4253.     write_frame_html(
  4254.         $title,        $html_filename, $top_basename,
  4255.         $toc_basename, $src_basename,  $src_frame_name
  4256.     );
  4257. }
  4258.  
  4259. sub write_toc_html {
  4260.  
  4261.     # write a separate html table of contents file for frames
  4262.     my ( $title, $toc_filename, $src_basename, $rtoc, $src_frame_name ) = @_;
  4263.     my $fh = IO::File->new( $toc_filename, 'w' )
  4264.       or die "Cannot open $toc_filename:$!\n";
  4265.     $fh->print(<<EOM);
  4266. <html>
  4267. <head>
  4268. <title>$title</title>
  4269. </head>
  4270. <body>
  4271. <h1><a href=\"$src_basename\"#-top-" target="$src_frame_name">$title</a></h1>
  4272. EOM
  4273.  
  4274.     my $first_anchor =
  4275.       change_anchor_names( $rtoc, $src_basename, "$src_frame_name" );
  4276.     $fh->print( join "", @$rtoc );
  4277.  
  4278.     $fh->print(<<EOM);
  4279. </body>
  4280. </html>
  4281. EOM
  4282.  
  4283. }
  4284.  
  4285. sub write_frame_html {
  4286.  
  4287.     # write an html file to be the table of contents frame
  4288.     my (
  4289.         $title,        $frame_filename, $top_basename,
  4290.         $toc_basename, $src_basename,   $src_frame_name
  4291.       )
  4292.       = @_;
  4293.  
  4294.     my $fh = IO::File->new( $frame_filename, 'w' )
  4295.       or die "Cannot open $toc_basename:$!\n";
  4296.  
  4297.     $fh->print(<<EOM);
  4298. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
  4299.     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd">
  4300. <?xml version="1.0" encoding="iso-8859-1" ?>
  4301. <html xmlns="http://www.w3.org/1999/xhtml">
  4302. <head>
  4303. <title>$title</title>
  4304. </head>
  4305. EOM
  4306.  
  4307.     # two left panels, one right, if master index file
  4308.     if ($top_basename) {
  4309.         $fh->print(<<EOM);
  4310. <frameset cols="20%,80%">
  4311. <frameset rows="30%,70%">
  4312. <frame src = "$top_basename" />
  4313. <frame src = "$toc_basename" />
  4314. </frameset>
  4315. EOM
  4316.     }
  4317.  
  4318.     # one left panels, one right, if no master index file
  4319.     else {
  4320.         $fh->print(<<EOM);
  4321. <frameset cols="20%,*">
  4322. <frame src = "$toc_basename" />
  4323. EOM
  4324.     }
  4325.     $fh->print(<<EOM);
  4326. <frame src = "$src_basename" name = "$src_frame_name" />
  4327. <noframes>
  4328. <body>
  4329. <p>If you see this message, you are using a non-frame-capable web client.</p>
  4330. <p>This document contains:</p>
  4331. <ul>
  4332. <li><a href="$toc_basename">A table of contents</a></li>
  4333. <li><a href="$src_basename">The source code</a></li>
  4334. </ul>
  4335. </body>
  4336. </noframes>
  4337. </frameset>
  4338. </html>
  4339. EOM
  4340. }
  4341.  
  4342. sub change_anchor_names {
  4343.  
  4344.     # add a filename and target to anchors
  4345.     # also return the first anchor
  4346.     my ( $rlines, $filename, $target ) = @_;
  4347.     my $first_anchor;
  4348.     foreach my $line (@$rlines) {
  4349.  
  4350.         #  We're looking for lines like this:
  4351.         #  <LI><A HREF="#synopsis">SYNOPSIS</A></LI>
  4352.         #  ----  -       --------  -----------------
  4353.         #  $1              $4            $5
  4354.         if ( $line =~ /^(.*)<a(.*)href\s*=\s*"([^#]*)#([^"]+)"[^>]*>(.*)$/i ) {
  4355.             my $pre  = $1;
  4356.             my $name = $4;
  4357.             my $post = $5;
  4358.             my $href = "$filename#$name";
  4359.             $line = "$pre<a href=\"$href\" target=\"$target\">$post\n";
  4360.             unless ($first_anchor) { $first_anchor = $href }
  4361.         }
  4362.     }
  4363.     return $first_anchor;
  4364. }
  4365.  
  4366. sub close_html_file {
  4367.     my $self = shift;
  4368.     return unless $self->{_html_file_opened};
  4369.  
  4370.     my $html_fh     = $self->{_html_fh};
  4371.     my $rtoc_string = $self->{_rtoc_string};
  4372.  
  4373.     # There are 3 basic paths to html output...
  4374.  
  4375.     # ---------------------------------
  4376.     # Path 1: finish up if in -pre mode
  4377.     # ---------------------------------
  4378.     if ( $rOpts->{'html-pre-only'} ) {
  4379.         $html_fh->print( <<"PRE_END");
  4380. </pre>
  4381. PRE_END
  4382.         eval { $html_fh->close() };
  4383.         return;
  4384.     }
  4385.  
  4386.     # Finish the index
  4387.     $self->add_toc_item( 'EOF', 'EOF' );
  4388.  
  4389.     my $rpre_string_stack = $self->{_rpre_string_stack};
  4390.  
  4391.     # Patch to darken the <pre> background color in case of pod2html and
  4392.     # interleaved code/documentation.  Otherwise, the distinction
  4393.     # between code and documentation is blurred.
  4394.     if (   $rOpts->{pod2html}
  4395.         && $self->{_pod_cut_count} >= 1
  4396.         && $rOpts->{'html-color-background'} eq '#FFFFFF' )
  4397.     {
  4398.         $rOpts->{'html-pre-color-background'} = '#F0F0F0';
  4399.     }
  4400.  
  4401.     # put the css or its link into a string, if used
  4402.     my $css_string;
  4403.     my $fh_css = Perl::Tidy::IOScalar->new( \$css_string, 'w' );
  4404.  
  4405.     # use css linked to another file
  4406.     if ( $rOpts->{'html-linked-style-sheet'} ) {
  4407.         $fh_css->print(
  4408.             qq(<link rel="stylesheet" href="$css_linkname" type="text/css" />)
  4409.         );
  4410.     }
  4411.  
  4412.     # use css embedded in this file
  4413.     elsif ( !$rOpts->{'nohtml-style-sheets'} ) {
  4414.         $fh_css->print( <<'ENDCSS');
  4415. <style type="text/css">
  4416. <!--
  4417. ENDCSS
  4418.         write_style_sheet_data($fh_css);
  4419.         $fh_css->print( <<"ENDCSS");
  4420. -->
  4421. </style>
  4422. ENDCSS
  4423.     }
  4424.  
  4425.     # -----------------------------------------------------------
  4426.     # path 2: use pod2html if requested
  4427.     #         If we fail for some reason, continue on to path 3
  4428.     # -----------------------------------------------------------
  4429.     if ( $rOpts->{'pod2html'} ) {
  4430.         my $rpod_string = $self->{_rpod_string};
  4431.         $self->pod_to_html( $$rpod_string, $css_string, $$rtoc_string,
  4432.             $rpre_string_stack )
  4433.           && return;
  4434.     }
  4435.  
  4436.     # --------------------------------------------------
  4437.     # path 3: write code in html, with pod only in italics
  4438.     # --------------------------------------------------
  4439.     my $input_file = $self->{_input_file};
  4440.     my $title      = escape_html($input_file);
  4441.     my $date       = localtime;
  4442.     $html_fh->print( <<"HTML_START");
  4443. <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" 
  4444.    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
  4445. <!-- Generated by perltidy on $date -->
  4446. <html xmlns="http://www.w3.org/1999/xhtml">
  4447. <head>
  4448. <title>$title</title>
  4449. HTML_START
  4450.  
  4451.     # output the css, if used
  4452.     if ($css_string) {
  4453.         $html_fh->print($css_string);
  4454.         $html_fh->print( <<"ENDCSS");
  4455. </head>
  4456. <body>
  4457. ENDCSS
  4458.     }
  4459.     else {
  4460.  
  4461.         $html_fh->print( <<"HTML_START");
  4462. </head>
  4463. <body bgcolor=\"$rOpts->{'html-color-background'}\" text=\"$rOpts->{'html-color-punctuation'}\">
  4464. HTML_START
  4465.     }
  4466.  
  4467.     $html_fh->print("<a name=\"-top-\"></a>\n");
  4468.     $html_fh->print( <<"EOM");
  4469. <h1>$title</h1>
  4470. EOM
  4471.  
  4472.     # copy the table of contents
  4473.     if (   $$rtoc_string
  4474.         && !$rOpts->{'frames'}
  4475.         && $rOpts->{'html-table-of-contents'} )
  4476.     {
  4477.         $html_fh->print($$rtoc_string);
  4478.     }
  4479.  
  4480.     # copy the pre section(s)
  4481.     my $fname_comment = $input_file;
  4482.     $fname_comment =~ s/--+/-/g;    # protect HTML comment tags
  4483.     $html_fh->print( <<"END_PRE");
  4484. <hr />
  4485. <!-- contents of filename: $fname_comment -->
  4486. <pre>
  4487. END_PRE
  4488.  
  4489.     foreach my $rpre_string (@$rpre_string_stack) {
  4490.         $html_fh->print($$rpre_string);
  4491.     }
  4492.  
  4493.     # and finish the html page
  4494.     $html_fh->print( <<"HTML_END");
  4495. </pre>
  4496. </body>
  4497. </html>
  4498. HTML_END
  4499.     eval { $html_fh->close() };    # could be object without close method
  4500.  
  4501.     if ( $rOpts->{'frames'} ) {
  4502.         my @toc = map { $_ .= "\n" } split /\n/, $$rtoc_string;
  4503.         $self->make_frame( \@toc );
  4504.     }
  4505. }
  4506.  
  4507. sub markup_tokens {
  4508.     my $self = shift;
  4509.     my ( $rtokens, $rtoken_type, $rlevels ) = @_;
  4510.     my ( @colored_tokens, $j, $string, $type, $token, $level );
  4511.     my $rlast_level     = $self->{_rlast_level};
  4512.     my $rin_toc_package = $self->{_rlast_level};
  4513.     my $rpackage_stack  = $self->{_rpackage_stack};
  4514.  
  4515.     for ( $j = 0 ; $j < @$rtoken_type ; $j++ ) {
  4516.         $type  = $$rtoken_type[$j];
  4517.         $token = $$rtokens[$j];
  4518.         $level = $$rlevels[$j];
  4519.         $level = 0 if ( $level < 0 );
  4520.  
  4521.         #-------------------------------------------------------
  4522.         # Update the package stack.  The package stack is needed to keep
  4523.         # the toc correct because some packages may be declared within
  4524.         # blocks and go out of scope when we leave the block.
  4525.         #-------------------------------------------------------
  4526.         if ( $level > $$rlast_level ) {
  4527.             unless ( $rpackage_stack->[ $level - 1 ] ) {
  4528.                 $rpackage_stack->[ $level - 1 ] = 'main';
  4529.             }
  4530.             $rpackage_stack->[$level] = $rpackage_stack->[ $level - 1 ];
  4531.         }
  4532.         elsif ( $level < $$rlast_level ) {
  4533.             my $package = $rpackage_stack->[$level];
  4534.             unless ($package) { $package = 'main' }
  4535.  
  4536.             # if we change packages due to a nesting change, we
  4537.             # have to make an entry in the toc
  4538.             if ( $package ne $rpackage_stack->[ $level + 1 ] ) {
  4539.                 $self->add_toc_item( $package, 'package' );
  4540.             }
  4541.         }
  4542.         $$rlast_level = $level;
  4543.  
  4544.         #-------------------------------------------------------
  4545.         # Intercept a sub name here; split it
  4546.         # into keyword 'sub' and sub name; and add an
  4547.         # entry in the toc
  4548.         #-------------------------------------------------------
  4549.         if ( $type eq 'i' && $token =~ /^(sub\s+)(\w.*)$/ ) {
  4550.             $token = $self->markup_html_element( $1, 'k' );
  4551.             push @colored_tokens, $token;
  4552.             $token = $2;
  4553.             $type  = 'M';
  4554.  
  4555.             # but don't include sub declarations in the toc;
  4556.             # these wlll have leading token types 'i;'
  4557.             my $signature = join "", @$rtoken_type;
  4558.             unless ( $signature =~ /^i;/ ) {
  4559.                 my $subname = $token;
  4560.                 $subname =~ s/[\s\(].*$//; # remove any attributes and prototype
  4561.                 $self->add_toc_item( $subname, 'sub' );
  4562.             }
  4563.         }
  4564.  
  4565.         #-------------------------------------------------------
  4566.         # Intercept a package name here; split it
  4567.         # into keyword 'package' and name; add to the toc,
  4568.         # and update the package stack
  4569.         #-------------------------------------------------------
  4570.         if ( $type eq 'i' && $token =~ /^(package\s+)(\w.*)$/ ) {
  4571.             $token = $self->markup_html_element( $1, 'k' );
  4572.             push @colored_tokens, $token;
  4573.             $token = $2;
  4574.             $type  = 'i';
  4575.             $self->add_toc_item( "$token", 'package' );
  4576.             $rpackage_stack->[$level] = $token;
  4577.         }
  4578.  
  4579.         $token = $self->markup_html_element( $token, $type );
  4580.         push @colored_tokens, $token;
  4581.     }
  4582.     return ( \@colored_tokens );
  4583. }
  4584.  
  4585. sub markup_html_element {
  4586.     my $self = shift;
  4587.     my ( $token, $type ) = @_;
  4588.  
  4589.     return $token if ( $type eq 'b' );    # skip a blank
  4590.     return $token if ( $token =~ /^\s*$/ );
  4591.     $token = escape_html($token);
  4592.  
  4593.     # get the short abbreviation for this token type
  4594.     my $short_name = $token_short_names{$type};
  4595.     if ( !defined($short_name) ) {
  4596.         $short_name = "pu";               # punctuation is default
  4597.     }
  4598.  
  4599.     # handle style sheets..
  4600.     if ( !$rOpts->{'nohtml-style-sheets'} ) {
  4601.         if ( $short_name ne 'pu' ) {
  4602.             $token = qq(<span class="$short_name">) . $token . "</span>";
  4603.         }
  4604.     }
  4605.  
  4606.     # handle no style sheets..
  4607.     else {
  4608.         my $color = $html_color{$short_name};
  4609.  
  4610.         if ( $color && ( $color ne $rOpts->{'html-color-punctuation'} ) ) {
  4611.             $token = qq(<font color="$color">) . $token . "</font>";
  4612.         }
  4613.         if ( $html_italic{$short_name} ) { $token = "<i>$token</i>" }
  4614.         if ( $html_bold{$short_name} )   { $token = "<b>$token</b>" }
  4615.     }
  4616.     return $token;
  4617. }
  4618.  
  4619. sub escape_html {
  4620.  
  4621.     my $token = shift;
  4622.     if ($missing_html_entities) {
  4623.         $token =~ s/\&/&/g;
  4624.         $token =~ s/\</</g;
  4625.         $token =~ s/\>/>/g;
  4626.         $token =~ s/\"/"/g;
  4627.     }
  4628.     else {
  4629.         HTML::Entities::encode_entities($token);
  4630.     }
  4631.     return $token;
  4632. }
  4633.  
  4634. sub finish_formatting {
  4635.  
  4636.     # called after last line
  4637.     my $self = shift;
  4638.     $self->close_html_file();
  4639.     return;
  4640. }
  4641.  
  4642. sub write_line {
  4643.  
  4644.     my $self = shift;
  4645.     return unless $self->{_html_file_opened};
  4646.     my $html_pre_fh = $self->{_html_pre_fh};
  4647.     my ($line_of_tokens) = @_;
  4648.     my $line_type   = $line_of_tokens->{_line_type};
  4649.     my $input_line  = $line_of_tokens->{_line_text};
  4650.     my $line_number = $line_of_tokens->{_line_number};
  4651.     chomp $input_line;
  4652.  
  4653.     # markup line of code..
  4654.     my $html_line;
  4655.     if ( $line_type eq 'CODE' ) {
  4656.         my $rtoken_type = $line_of_tokens->{_rtoken_type};
  4657.         my $rtokens     = $line_of_tokens->{_rtokens};
  4658.         my $rlevels     = $line_of_tokens->{_rlevels};
  4659.  
  4660.         if ( $input_line =~ /(^\s*)/ ) {
  4661.             $html_line = $1;
  4662.         }
  4663.         else {
  4664.             $html_line = "";
  4665.         }
  4666.         my ($rcolored_tokens) =
  4667.           $self->markup_tokens( $rtokens, $rtoken_type, $rlevels );
  4668.         $html_line .= join '', @$rcolored_tokens;
  4669.     }
  4670.  
  4671.     # markup line of non-code..
  4672.     else {
  4673.         my $line_character;
  4674.         if    ( $line_type eq 'HERE' )       { $line_character = 'H' }
  4675.         elsif ( $line_type eq 'HERE_END' )   { $line_character = 'h' }
  4676.         elsif ( $line_type eq 'FORMAT' )     { $line_character = 'H' }
  4677.         elsif ( $line_type eq 'FORMAT_END' ) { $line_character = 'h' }
  4678.         elsif ( $line_type eq 'SYSTEM' )     { $line_character = 'c' }
  4679.         elsif ( $line_type eq 'END_START' )  {
  4680.             $line_character = 'k';
  4681.             $self->add_toc_item( '__END__', '__END__' );
  4682.         }
  4683.         elsif ( $line_type eq 'DATA_START' ) {
  4684.             $line_character = 'k';
  4685.             $self->add_toc_item( '__DATA__', '__DATA__' );
  4686.         }
  4687.         elsif ( $line_type =~ /^POD/ ) {
  4688.             $line_character = 'P';
  4689.             if ( $rOpts->{'pod2html'} ) {
  4690.                 my $html_pod_fh = $self->{_html_pod_fh};
  4691.                 if ( $line_type eq 'POD_START' ) {
  4692.  
  4693.                     my $rpre_string_stack = $self->{_rpre_string_stack};
  4694.                     my $rpre_string       = $rpre_string_stack->[-1];
  4695.  
  4696.                     # if we have written any non-blank lines to the
  4697.                     # current pre section, start writing to a new output
  4698.                     # string
  4699.                     if ( $$rpre_string =~ /\S/ ) {
  4700.                         my $pre_string;
  4701.                         $html_pre_fh =
  4702.                           Perl::Tidy::IOScalar->new( \$pre_string, 'w' );
  4703.                         $self->{_html_pre_fh} = $html_pre_fh;
  4704.                         push @$rpre_string_stack, \$pre_string;
  4705.  
  4706.                         # leave a marker in the pod stream so we know
  4707.                         # where to put the pre section we just
  4708.                         # finished.
  4709.                         my $for_html = '=for html';    # don't confuse pod utils
  4710.                         $html_pod_fh->print(<<EOM);
  4711.  
  4712. $for_html
  4713. <!-- pERLTIDY sECTION -->
  4714.  
  4715. EOM
  4716.                     }
  4717.  
  4718.                     # otherwise, just clear the current string and start
  4719.                     # over
  4720.                     else {
  4721.                         $$rpre_string = "";
  4722.                         $html_pod_fh->print("\n");
  4723.                     }
  4724.                 }
  4725.                 $html_pod_fh->print( $input_line . "\n" );
  4726.                 if ( $line_type eq 'POD_END' ) {
  4727.                     $self->{_pod_cut_count}++;
  4728.                     $html_pod_fh->print("\n");
  4729.                 }
  4730.                 return;
  4731.             }
  4732.         }
  4733.         else { $line_character = 'Q' }
  4734.         $html_line = $self->markup_html_element( $input_line, $line_character );
  4735.     }
  4736.  
  4737.     # add the line number if requested
  4738.     if ( $rOpts->{'html-line-numbers'} ) {
  4739.         my $extra_space .= ( $line_number < 10 ) ? "   "
  4740.           : ( $line_number < 100 )  ? "  "
  4741.           : ( $line_number < 1000 ) ? " "
  4742.           : "";
  4743.         $html_line = $extra_space . $line_number . " " . $html_line;
  4744.     }
  4745.  
  4746.     # write the line
  4747.     $html_pre_fh->print("$html_line\n");
  4748. }
  4749.  
  4750. #####################################################################
  4751. #
  4752. # The Perl::Tidy::Formatter package adds indentation, whitespace, and
  4753. # line breaks to the token stream
  4754. #
  4755. # WARNING: This is not a real class for speed reasons.  Only one
  4756. # Formatter may be used.
  4757. #
  4758. #####################################################################
  4759.  
  4760. package Perl::Tidy::Formatter;
  4761.  
  4762. BEGIN {
  4763.  
  4764.     # Caution: these debug flags produce a lot of output
  4765.     # They should all be 0 except when debugging small scripts
  4766.     use constant FORMATTER_DEBUG_FLAG_BOND    => 0;
  4767.     use constant FORMATTER_DEBUG_FLAG_BREAK   => 0;
  4768.     use constant FORMATTER_DEBUG_FLAG_CI      => 0;
  4769.     use constant FORMATTER_DEBUG_FLAG_FLUSH   => 0;
  4770.     use constant FORMATTER_DEBUG_FLAG_FORCE   => 0;
  4771.     use constant FORMATTER_DEBUG_FLAG_LIST    => 0;
  4772.     use constant FORMATTER_DEBUG_FLAG_NOBREAK => 0;
  4773.     use constant FORMATTER_DEBUG_FLAG_OUTPUT  => 0;
  4774.     use constant FORMATTER_DEBUG_FLAG_SPARSE  => 0;
  4775.     use constant FORMATTER_DEBUG_FLAG_STORE   => 0;
  4776.     use constant FORMATTER_DEBUG_FLAG_UNDOBP  => 0;
  4777.     use constant FORMATTER_DEBUG_FLAG_WHITE   => 0;
  4778.  
  4779.     my $debug_warning = sub {
  4780.         print "FORMATTER_DEBUGGING with key $_[0]\n";
  4781.     };
  4782.  
  4783.     FORMATTER_DEBUG_FLAG_BOND    && $debug_warning->('BOND');
  4784.     FORMATTER_DEBUG_FLAG_BREAK   && $debug_warning->('BREAK');
  4785.     FORMATTER_DEBUG_FLAG_CI      && $debug_warning->('CI');
  4786.     FORMATTER_DEBUG_FLAG_FLUSH   && $debug_warning->('FLUSH');
  4787.     FORMATTER_DEBUG_FLAG_FORCE   && $debug_warning->('FORCE');
  4788.     FORMATTER_DEBUG_FLAG_LIST    && $debug_warning->('LIST');
  4789.     FORMATTER_DEBUG_FLAG_NOBREAK && $debug_warning->('NOBREAK');
  4790.     FORMATTER_DEBUG_FLAG_OUTPUT  && $debug_warning->('OUTPUT');
  4791.     FORMATTER_DEBUG_FLAG_SPARSE  && $debug_warning->('SPARSE');
  4792.     FORMATTER_DEBUG_FLAG_STORE   && $debug_warning->('STORE');
  4793.     FORMATTER_DEBUG_FLAG_UNDOBP  && $debug_warning->('UNDOBP');
  4794.     FORMATTER_DEBUG_FLAG_WHITE   && $debug_warning->('WHITE');
  4795. }
  4796.  
  4797. use Carp;
  4798. use vars qw{
  4799.  
  4800.   @gnu_stack
  4801.   $max_gnu_stack_index
  4802.   $gnu_position_predictor
  4803.   $line_start_index_to_go
  4804.   $last_indentation_written
  4805.   $last_unadjusted_indentation
  4806.  
  4807.   $saw_VERSION_in_this_file
  4808.   $saw_END_or_DATA_
  4809.  
  4810.   @gnu_item_list
  4811.   $max_gnu_item_index
  4812.   $gnu_sequence_number
  4813.   $last_output_indentation
  4814.   %last_gnu_equals
  4815.   %gnu_comma_count
  4816.   %gnu_arrow_count
  4817.  
  4818.   @block_type_to_go
  4819.   @type_sequence_to_go
  4820.   @container_environment_to_go
  4821.   @bond_strength_to_go
  4822.   @forced_breakpoint_to_go
  4823.   @lengths_to_go
  4824.   @levels_to_go
  4825.   @leading_spaces_to_go
  4826.   @reduced_spaces_to_go
  4827.   @matching_token_to_go
  4828.   @mate_index_to_go
  4829.   @nesting_blocks_to_go
  4830.   @ci_levels_to_go
  4831.   @nesting_depth_to_go
  4832.   @nobreak_to_go
  4833.   @old_breakpoint_to_go
  4834.   @tokens_to_go
  4835.   @types_to_go
  4836.  
  4837.   %saved_opening_indentation
  4838.  
  4839.   $max_index_to_go
  4840.   $comma_count_in_batch
  4841.   $old_line_count_in_batch
  4842.   $last_nonblank_index_to_go
  4843.   $last_nonblank_type_to_go
  4844.   $last_nonblank_token_to_go
  4845.   $last_last_nonblank_index_to_go
  4846.   $last_last_nonblank_type_to_go
  4847.   $last_last_nonblank_token_to_go
  4848.   @nonblank_lines_at_depth
  4849.  
  4850.   $forced_breakpoint_count
  4851.   $forced_breakpoint_undo_count
  4852.   @forced_breakpoint_undo_stack
  4853.   %postponed_breakpoint
  4854.  
  4855.   $tabbing
  4856.   $embedded_tab_count
  4857.   $first_embedded_tab_at
  4858.   $last_embedded_tab_at
  4859.   $deleted_semicolon_count
  4860.   $first_deleted_semicolon_at
  4861.   $last_deleted_semicolon_at
  4862.   $added_semicolon_count
  4863.   $first_added_semicolon_at
  4864.   $last_added_semicolon_at
  4865.   $saw_negative_indentation
  4866.   $first_tabbing_disagreement
  4867.   $last_tabbing_disagreement
  4868.   $in_tabbing_disagreement
  4869.   $tabbing_disagreement_count
  4870.   $input_line_tabbing
  4871.  
  4872.   $last_line_type
  4873.   $last_line_leading_type
  4874.   $last_line_leading_level
  4875.   $last_last_line_leading_level
  4876.  
  4877.   %block_leading_text
  4878.   %block_opening_line_number
  4879.   $csc_new_statement_ok
  4880.   $accumulating_text_for_block
  4881.   $leading_block_text
  4882.   $rleading_block_if_elsif_text
  4883.   $leading_block_text_level
  4884.   $leading_block_text_length_exceeded
  4885.   $leading_block_text_line_length
  4886.   $leading_block_text_line_number
  4887.   $closing_side_comment_prefix_pattern
  4888.   $closing_side_comment_list_pattern
  4889.  
  4890.   $last_nonblank_token
  4891.   $last_nonblank_type
  4892.   $last_last_nonblank_token
  4893.   $last_last_nonblank_type
  4894.   $last_nonblank_block_type
  4895.   $last_output_level
  4896.   %is_do_follower
  4897.   %is_if_brace_follower
  4898.   %space_before_paren
  4899.   $rbrace_follower
  4900.   $looking_for_else
  4901.   %is_other_brace_follower
  4902.   %is_else_brace_follower
  4903.   %is_anon_sub_brace_follower
  4904.   %is_anon_sub_1_brace_follower
  4905.   %is_sort_map_grep
  4906.   %is_sort_map_grep_eval
  4907.   %is_block_without_semicolon
  4908.   %is_if_unless_and_or
  4909.  
  4910.   @has_broken_sublist
  4911.   @dont_align
  4912.   @want_comma_break
  4913.  
  4914.   $index_start_one_line_block
  4915.   $semicolons_before_block_self_destruct
  4916.   $index_max_forced_break
  4917.   $input_line_number
  4918.   $diagnostics_object
  4919.   $vertical_aligner_object
  4920.   $logger_object
  4921.   $file_writer_object
  4922.   $formatter_self
  4923.   @ci_stack
  4924.   $last_line_had_side_comment
  4925.   %want_break_before
  4926.   %outdent_keyword
  4927.   $static_block_comment_pattern
  4928.   $static_side_comment_pattern
  4929.   %opening_vertical_tightness
  4930.   %closing_vertical_tightness
  4931.   $block_brace_vertical_tightness_pattern
  4932.  
  4933.   $rOpts_add_newlines
  4934.   $rOpts_add_whitespace
  4935.   $rOpts_block_brace_tightness
  4936.   $rOpts_block_brace_vertical_tightness
  4937.   $rOpts_brace_left_and_indent
  4938.   $rOpts_comma_arrow_breakpoints
  4939.   $rOpts_break_at_old_keyword_breakpoints
  4940.   $rOpts_break_at_old_comma_breakpoints
  4941.   $rOpts_break_at_old_logical_breakpoints
  4942.   $rOpts_break_at_old_trinary_breakpoints
  4943.   $rOpts_closing_side_comment_else_flag
  4944.   $rOpts_closing_side_comment_maximum_text
  4945.   $rOpts_continuation_indentation
  4946.   $rOpts_cuddled_else
  4947.   $rOpts_delete_old_whitespace
  4948.   $rOpts_fuzzy_line_length
  4949.   $rOpts_indent_columns
  4950.   $rOpts_line_up_parentheses
  4951.   $rOpts_maximum_fields_per_table
  4952.   $rOpts_maximum_line_length
  4953.   $rOpts_short_concatenation_item_length
  4954.   $rOpts_swallow_optional_blank_lines
  4955.   $rOpts_ignore_old_line_breaks
  4956.  
  4957.   $half_maximum_line_length
  4958.  
  4959.   %is_opening_type
  4960.   %is_closing_type
  4961.   %is_keyword_returning_list
  4962.   %tightness
  4963.   %matching_token
  4964.   $rOpts
  4965.   %right_bond_strength
  4966.   %left_bond_strength
  4967.   %binary_ws_rules
  4968.   %want_left_space
  4969.   %want_right_space
  4970.   %is_digraph
  4971.   %is_trigraph
  4972.   $bli_pattern
  4973.   $bli_list_string
  4974.   %is_closing_type
  4975.   %is_opening_type
  4976.   %is_closing_token
  4977.   %is_opening_token
  4978. };
  4979.  
  4980. BEGIN {
  4981.  
  4982.     # default list of block types for which -bli would apply
  4983.     $bli_list_string = 'if else elsif unless while for foreach do : sub';
  4984.  
  4985.     @_ = qw(
  4986.       .. :: << >> ** && .. ||  -> => += -= .= %= &= |= ^= *= <>
  4987.       <= >= == =~ !~ != ++ -- /= x=
  4988.     );
  4989.     @is_digraph{@_} = (1) x scalar(@_);
  4990.  
  4991.     @_ = qw( ... **= <<= >>= &&= ||= <=> );
  4992.     @is_trigraph{@_} = (1) x scalar(@_);
  4993.  
  4994.     @_ = qw(
  4995.       grep
  4996.       keys
  4997.       map
  4998.       reverse
  4999.       sort
  5000.       split
  5001.     );
  5002.     @is_keyword_returning_list{@_} = (1) x scalar(@_);
  5003.  
  5004.     @_ = qw(sort map grep);
  5005.     @is_sort_map_grep{@_} = (1) x scalar(@_);
  5006.  
  5007.     @_ = qw(sort map grep eval);
  5008.     @is_sort_map_grep_eval{@_} = (1) x scalar(@_);
  5009.  
  5010.     @_ = qw(if unless and or);
  5011.     @is_if_unless_and_or{@_} = (1) x scalar(@_);
  5012.  
  5013.     # We can remove semicolons after blocks preceded by these keywords
  5014.     @_ = qw(BEGIN END CHECK INIT AUTOLOAD DESTROY continue if elsif else
  5015.       unless while until for foreach);
  5016.     @is_block_without_semicolon{@_} = (1) x scalar(@_);
  5017.  
  5018.     # 'L' is token for opening { at hash key
  5019.     @_ = qw" L { ( [ ";
  5020.     @is_opening_type{@_} = (1) x scalar(@_);
  5021.  
  5022.     # 'R' is token for closing } at hash key
  5023.     @_ = qw" R } ) ] ";
  5024.     @is_closing_type{@_} = (1) x scalar(@_);
  5025.  
  5026.     @_ = qw" { ( [ ";
  5027.     @is_opening_token{@_} = (1) x scalar(@_);
  5028.  
  5029.     @_ = qw" } ) ] ";
  5030.     @is_closing_token{@_} = (1) x scalar(@_);
  5031. }
  5032.  
  5033. # whitespace codes
  5034. use constant WS_YES      => 1;
  5035. use constant WS_OPTIONAL => 0;
  5036. use constant WS_NO       => -1;
  5037.  
  5038. # Token bond strengths.
  5039. use constant NO_BREAK    => 10000;
  5040. use constant VERY_STRONG => 100;
  5041. use constant STRONG      => 2.1;
  5042. use constant NOMINAL     => 1.1;
  5043. use constant WEAK        => 0.8;
  5044. use constant VERY_WEAK   => 0.55;
  5045.  
  5046. # values for testing indexes in output array
  5047. use constant UNDEFINED_INDEX => -1;
  5048.  
  5049. # Maximum number of little messages; probably need not be changed.
  5050. use constant MAX_NAG_MESSAGES => 6;
  5051.  
  5052. # increment between sequence numbers for each type
  5053. # For example, ?: pairs might have numbers 7,11,15,...
  5054. use constant TYPE_SEQUENCE_INCREMENT => 4;
  5055.  
  5056. {
  5057.  
  5058.     # methods to count instances
  5059.     my $_count = 0;
  5060.     sub get_count        { $_count; }
  5061.     sub _increment_count { ++$_count }
  5062.     sub _decrement_count { --$_count }
  5063. }
  5064.  
  5065. # interface to Perl::Tidy::Logger routines
  5066. sub warning {
  5067.     if ($logger_object) {
  5068.         $logger_object->warning(@_);
  5069.     }
  5070. }
  5071.  
  5072. sub complain {
  5073.     if ($logger_object) {
  5074.         $logger_object->complain(@_);
  5075.     }
  5076. }
  5077.  
  5078. sub write_logfile_entry {
  5079.     if ($logger_object) {
  5080.         $logger_object->write_logfile_entry(@_);
  5081.     }
  5082. }
  5083.  
  5084. sub black_box {
  5085.     if ($logger_object) {
  5086.         $logger_object->black_box(@_);
  5087.     }
  5088. }
  5089.  
  5090. sub report_definite_bug {
  5091.     if ($logger_object) {
  5092.         $logger_object->report_definite_bug();
  5093.     }
  5094. }
  5095.  
  5096. sub get_saw_brace_error {
  5097.     if ($logger_object) {
  5098.         $logger_object->get_saw_brace_error();
  5099.     }
  5100. }
  5101.  
  5102. sub we_are_at_the_last_line {
  5103.     if ($logger_object) {
  5104.         $logger_object->we_are_at_the_last_line();
  5105.     }
  5106. }
  5107.  
  5108. # interface to Perl::Tidy::Diagnostics routine
  5109. sub write_diagnostics {
  5110.  
  5111.     if ($diagnostics_object) {
  5112.         $diagnostics_object->write_diagnostics(@_);
  5113.     }
  5114. }
  5115.  
  5116. sub get_added_semicolon_count {
  5117.     my $self = shift;
  5118.     return $added_semicolon_count;
  5119. }
  5120.  
  5121. sub DESTROY {
  5122.     $_[0]->_decrement_count();
  5123. }
  5124.  
  5125. sub new {
  5126.  
  5127.     my $class = shift;
  5128.  
  5129.     # we are given an object with a write_line() method to take lines
  5130.     my %defaults = (
  5131.         sink_object        => undef,
  5132.         diagnostics_object => undef,
  5133.         logger_object      => undef,
  5134.     );
  5135.     my %args = ( %defaults, @_ );
  5136.  
  5137.     $logger_object      = $args{logger_object};
  5138.     $diagnostics_object = $args{diagnostics_object};
  5139.  
  5140.     # FIXME: we create another object with a get_line() and peek_ahead() method
  5141.     my $sink_object = $args{sink_object};
  5142.     $file_writer_object =
  5143.       Perl::Tidy::FileWriter->new( $sink_object, $rOpts, $logger_object );
  5144.  
  5145.     # initialize the leading whitespace stack to negative levels
  5146.     # so that we can never run off the end of the stack
  5147.     $gnu_position_predictor = 0;    # where the current token is predicted to be
  5148.     $max_gnu_stack_index    = 0;
  5149.     $max_gnu_item_index     = -1;
  5150.     $gnu_stack[0] = new_lp_indentation_item( 0, -1, -1, 0, 0 );
  5151.     @gnu_item_list               = ();
  5152.     $last_output_indentation     = 0;
  5153.     $last_indentation_written    = 0;
  5154.     $last_unadjusted_indentation = 0;
  5155.  
  5156.     $saw_VERSION_in_this_file = !$rOpts->{'pass-version-line'};
  5157.     $saw_END_or_DATA_         = 0;
  5158.  
  5159.     @block_type_to_go            = ();
  5160.     @type_sequence_to_go         = ();
  5161.     @container_environment_to_go = ();
  5162.     @bond_strength_to_go         = ();
  5163.     @forced_breakpoint_to_go     = ();
  5164.     @lengths_to_go               = ();    # line length to start of ith token
  5165.     @levels_to_go                = ();
  5166.     @matching_token_to_go        = ();
  5167.     @mate_index_to_go            = ();
  5168.     @nesting_blocks_to_go        = ();
  5169.     @ci_levels_to_go             = ();
  5170.     @nesting_depth_to_go         = (0);
  5171.     @nobreak_to_go               = ();
  5172.     @old_breakpoint_to_go        = ();
  5173.     @tokens_to_go                = ();
  5174.     @types_to_go                 = ();
  5175.     @leading_spaces_to_go        = ();
  5176.     @reduced_spaces_to_go        = ();
  5177.  
  5178.     @dont_align         = ();
  5179.     @has_broken_sublist = ();
  5180.     @want_comma_break   = ();
  5181.  
  5182.     @ci_stack                   = ("");
  5183.     $saw_negative_indentation   = 0;
  5184.     $first_tabbing_disagreement = 0;
  5185.     $last_tabbing_disagreement  = 0;
  5186.     $tabbing_disagreement_count = 0;
  5187.     $in_tabbing_disagreement    = 0;
  5188.     $input_line_tabbing         = undef;
  5189.  
  5190.     $last_line_type               = "";
  5191.     $last_last_line_leading_level = 0;
  5192.     $last_line_leading_level      = 0;
  5193.     $last_line_leading_type       = '#';
  5194.  
  5195.     $last_nonblank_token        = ';';
  5196.     $last_nonblank_type         = ';';
  5197.     $last_last_nonblank_token   = ';';
  5198.     $last_last_nonblank_type    = ';';
  5199.     $last_nonblank_block_type   = "";
  5200.     $last_output_level          = 0;
  5201.     $looking_for_else           = 0;
  5202.     $embedded_tab_count         = 0;
  5203.     $first_embedded_tab_at      = 0;
  5204.     $last_embedded_tab_at       = 0;
  5205.     $deleted_semicolon_count    = 0;
  5206.     $first_deleted_semicolon_at = 0;
  5207.     $last_deleted_semicolon_at  = 0;
  5208.     $added_semicolon_count      = 0;
  5209.     $first_added_semicolon_at   = 0;
  5210.     $last_added_semicolon_at    = 0;
  5211.     $last_line_had_side_comment = 0;
  5212.     %postponed_breakpoint       = ();
  5213.  
  5214.     # variables for adding side comments
  5215.     %block_leading_text        = ();
  5216.     %block_opening_line_number = ();
  5217.     $csc_new_statement_ok      = 1;
  5218.  
  5219.     %saved_opening_indentation = ();
  5220.  
  5221.     reset_block_text_accumulator();
  5222.  
  5223.     prepare_for_new_input_lines();
  5224.  
  5225.     $vertical_aligner_object =
  5226.       Perl::Tidy::VerticalAligner->initialize( $rOpts, $file_writer_object,
  5227.         $logger_object, $diagnostics_object );
  5228.  
  5229.     if ( $rOpts->{'entab-leading-whitespace'} ) {
  5230.         write_logfile_entry(
  5231. "Leading whitespace will be entabbed with $rOpts->{'entab-leading-whitespace'} spaces per tab\n"
  5232.         );
  5233.     }
  5234.     elsif ( $rOpts->{'tabs'} ) {
  5235.         write_logfile_entry("Indentation will be with a tab character\n");
  5236.     }
  5237.     else {
  5238.         write_logfile_entry(
  5239.             "Indentation will be with $rOpts->{'indent-columns'} spaces\n");
  5240.     }
  5241.  
  5242.     # This was the start of a formatter referent, but object-oriented
  5243.     # coding has turned out to be too slow here.
  5244.     $formatter_self = {};
  5245.  
  5246.     bless $formatter_self, $class;
  5247.  
  5248.     # Safety check..this is not a class yet
  5249.     if ( _increment_count() > 1 ) {
  5250.         confess
  5251. "Attempt to create more than 1 object in $class, which is not a true class yet\n";
  5252.     }
  5253.     return $formatter_self;
  5254. }
  5255.  
  5256. sub prepare_for_new_input_lines {
  5257.  
  5258.     $gnu_sequence_number++;    # increment output batch counter
  5259.     %last_gnu_equals                = ();
  5260.     %gnu_comma_count                = ();
  5261.     %gnu_arrow_count                = ();
  5262.     $line_start_index_to_go         = 0;
  5263.     $max_gnu_item_index             = UNDEFINED_INDEX;
  5264.     $index_max_forced_break         = UNDEFINED_INDEX;
  5265.     $max_index_to_go                = UNDEFINED_INDEX;
  5266.     $last_nonblank_index_to_go      = UNDEFINED_INDEX;
  5267.     $last_nonblank_type_to_go       = '';
  5268.     $last_nonblank_token_to_go      = '';
  5269.     $last_last_nonblank_index_to_go = UNDEFINED_INDEX;
  5270.     $last_last_nonblank_type_to_go  = '';
  5271.     $last_last_nonblank_token_to_go = '';
  5272.     $forced_breakpoint_count        = 0;
  5273.     $forced_breakpoint_undo_count   = 0;
  5274.     $rbrace_follower                = undef;
  5275.     $lengths_to_go[0]               = 0;
  5276.     $old_line_count_in_batch        = 1;
  5277.     $comma_count_in_batch           = 0;
  5278.  
  5279.     destroy_one_line_block();
  5280. }
  5281.  
  5282. sub write_line {
  5283.  
  5284.     my $self = shift;
  5285.     my ($line_of_tokens) = @_;
  5286.  
  5287.     my $line_type            = $line_of_tokens->{_line_type};
  5288.     my $input_line           = $line_of_tokens->{_line_text};
  5289.     my $want_blank_line_next = 0;
  5290.  
  5291.     # _line_type codes are:
  5292.     #   SYSTEM         - system-specific code before hash-bang line
  5293.     #   CODE           - line of perl code (including comments)
  5294.     #   POD_START      - line starting pod, such as '=head'
  5295.     #   POD            - pod documentation text
  5296.     #   POD_END        - last line of pod section, '=cut'
  5297.     #   HERE           - text of here-document
  5298.     #   HERE_END       - last line of here-doc (target word)
  5299.     #   FORMAT         - format section
  5300.     #   FORMAT_END     - last line of format section, '.'
  5301.     #   DATA_START     - __DATA__ line
  5302.     #   DATA           - unidentified text following __DATA__
  5303.     #   END_START      - __END__ line
  5304.     #   END            - unidentified text following __END__
  5305.     #   ERROR          - we are in big trouble, probably not a perl script
  5306.     #
  5307.     # handle line of code..
  5308.     if ( $line_type eq 'CODE' ) {
  5309.  
  5310.         # let logger see all non-blank lines of code
  5311.         if ( $input_line !~ /^\s*$/ ) {
  5312.             my $output_line_number =
  5313.               $vertical_aligner_object->get_output_line_number();
  5314.             black_box( $line_of_tokens, $output_line_number );
  5315.         }
  5316.         print_line_of_tokens($line_of_tokens);
  5317.     }
  5318.  
  5319.     # handle line of non-code..
  5320.     else {
  5321.  
  5322.         # set special flags
  5323.         my $skip_line = 0;
  5324.         my $tee_line  = 0;
  5325.         if ( $line_type =~ /^POD/ ) {
  5326.  
  5327.             # Pod docs should have a preceding blank line.  But be
  5328.             # very careful in __END__ and __DATA__ sections, because:
  5329.             #   1. the user may be using this section for any purpose whatsoever
  5330.             #   2. the blank counters are not active there
  5331.             # It should be safe to request a blank line between an
  5332.             # __END__ or __DATA__ and an immediately following '=head'
  5333.             # type line, (types END_START and DATA_START), but not for
  5334.             # any other lines of type END or DATA.
  5335.             if ( $rOpts->{'delete-pod'} ) { $skip_line = 1; }
  5336.             if ( $rOpts->{'tee-pod'} )    { $tee_line  = 1; }
  5337.             if (   !$skip_line
  5338.                 && $line_type eq 'POD_START'
  5339.                 && $last_line_type !~ /^(END|DATA)$/ )
  5340.             {
  5341.                 want_blank_line();
  5342.             }
  5343.  
  5344.             # patch to put a blank line after =cut
  5345.             # (required by podchecker)
  5346.             if ( $line_type eq 'POD_END' && !$saw_END_or_DATA_ ) {
  5347.                 $file_writer_object->reset_consecutive_blank_lines();
  5348.                 $want_blank_line_next = 1;
  5349.             }
  5350.         }
  5351.  
  5352.         # leave the blank counters in a predictable state
  5353.         # after __END__ or __DATA__
  5354.         elsif ( $line_type =~ /^(END_START|DATA_START)$/ ) {
  5355.             $file_writer_object->reset_consecutive_blank_lines();
  5356.             $saw_END_or_DATA_ = 1;
  5357.         }
  5358.  
  5359.         # write unindented non-code line
  5360.         if ( !$skip_line ) {
  5361.             if ($tee_line) { $file_writer_object->tee_on() }
  5362.             write_unindented_line($input_line);
  5363.             if ($tee_line)             { $file_writer_object->tee_off() }
  5364.             if ($want_blank_line_next) { want_blank_line(); }
  5365.         }
  5366.     }
  5367.     $last_line_type = $line_type;
  5368. }
  5369.  
  5370. sub create_one_line_block {
  5371.     $index_start_one_line_block            = $_[0];
  5372.     $semicolons_before_block_self_destruct = $_[1];
  5373. }
  5374.  
  5375. sub destroy_one_line_block {
  5376.     $index_start_one_line_block            = UNDEFINED_INDEX;
  5377.     $semicolons_before_block_self_destruct = 0;
  5378. }
  5379.  
  5380. sub leading_spaces_to_go {
  5381.  
  5382.     # return the number of indentation spaces for a token in the output stream;
  5383.     # these were previously stored by 'set_leading_whitespace'.
  5384.  
  5385.     return get_SPACES( $leading_spaces_to_go[ $_[0] ] );
  5386.  
  5387. }
  5388.  
  5389. sub get_SPACES {
  5390.  
  5391.     # return the number of leading spaces associated with an indentation
  5392.     # variable $indentation is either a constant number of spaces or an object
  5393.     # with a get_SPACES method.
  5394.     my $indentation = shift;
  5395.     return ref($indentation) ? $indentation->get_SPACES() : $indentation;
  5396. }
  5397.  
  5398. sub get_AVAILABLE_SPACES_to_go {
  5399.  
  5400.     my $item = $leading_spaces_to_go[ $_[0] ];
  5401.  
  5402.     # return the number of available leading spaces associated with an
  5403.     # indentation variable.  $indentation is either a constant number of
  5404.     # spaces or an object with a get_AVAILABLE_SPACES method.
  5405.     return ref($item) ? $item->get_AVAILABLE_SPACES() : 0;
  5406. }
  5407.  
  5408. sub new_lp_indentation_item {
  5409.  
  5410.     # this is an interface to the IndentationItem class
  5411.     my ( $spaces, $level, $ci_level, $available_spaces, $align_paren ) = @_;
  5412.  
  5413.     # A negative level implies not to store the item in the item_list
  5414.     my $index = 0;
  5415.     if ( $level >= 0 ) { $index = ++$max_gnu_item_index; }
  5416.  
  5417.     my $item = Perl::Tidy::IndentationItem->new(
  5418.         $spaces,      $level,
  5419.         $ci_level,    $available_spaces,
  5420.         $index,       $gnu_sequence_number,
  5421.         $align_paren, $max_gnu_stack_index,
  5422.         $line_start_index_to_go,
  5423.     );
  5424.  
  5425.     if ( $level >= 0 ) {
  5426.         $gnu_item_list[$max_gnu_item_index] = $item;
  5427.     }
  5428.  
  5429.     return $item;
  5430. }
  5431.  
  5432. sub set_leading_whitespace {
  5433.  
  5434.     # This routine defines leading whitespace
  5435.     # given: the level and continuation_level of a token,
  5436.     # define: space count of leading string which would apply if it
  5437.     # were the first token of a new line.
  5438.  
  5439.     my ( $level, $ci_level, $in_continued_quote ) = @_;
  5440.  
  5441.     # modify for -bli, which adds one continuation indentation for
  5442.     # opening braces
  5443.     if (   $rOpts_brace_left_and_indent
  5444.         && $max_index_to_go == 0
  5445.         && $block_type_to_go[$max_index_to_go] =~ /$bli_pattern/o )
  5446.     {
  5447.         $ci_level++;
  5448.     }
  5449.  
  5450.     # patch to avoid trouble when input file has negative indentation.
  5451.     # other logic should catch this error.
  5452.     if ( $level < 0 ) { $level = 0 }
  5453.  
  5454.     #-------------------------------------------
  5455.     # handle the standard indentation scheme
  5456.     #-------------------------------------------
  5457.     unless ($rOpts_line_up_parentheses) {
  5458.         my $space_count = $ci_level * $rOpts_continuation_indentation + $level *
  5459.           $rOpts_indent_columns;
  5460.         my $ci_spaces =
  5461.           ( $ci_level == 0 ) ? 0 : $rOpts_continuation_indentation;
  5462.  
  5463.         if ($in_continued_quote) {
  5464.             $space_count = 0;
  5465.             $ci_spaces   = 0;
  5466.         }
  5467.         $leading_spaces_to_go[$max_index_to_go] = $space_count;
  5468.         $reduced_spaces_to_go[$max_index_to_go] = $space_count - $ci_spaces;
  5469.         return;
  5470.     }
  5471.  
  5472.     #-------------------------------------------------------------
  5473.     # handle case of -lp indentation..
  5474.     #-------------------------------------------------------------
  5475.  
  5476.     # The continued_quote flag means that this is the first token of a
  5477.     # line, and it is the continuation of some kind of multi-line quote
  5478.     # or pattern.  It requires special treatment because it must have no
  5479.     # added leading whitespace. So we create a special indentation item
  5480.     # which is not in the stack.
  5481.     if ($in_continued_quote) {
  5482.         my $space_count     = 0;
  5483.         my $available_space = 0;
  5484.         $level = -1;    # flag to prevent storing in item_list
  5485.         $leading_spaces_to_go[$max_index_to_go]   =
  5486.           $reduced_spaces_to_go[$max_index_to_go] =
  5487.           new_lp_indentation_item( $space_count, $level, $ci_level,
  5488.             $available_space, 0 );
  5489.         return;
  5490.     }
  5491.  
  5492.     # get the top state from the stack
  5493.     my $space_count      = $gnu_stack[$max_gnu_stack_index]->get_SPACES();
  5494.     my $current_level    = $gnu_stack[$max_gnu_stack_index]->get_LEVEL();
  5495.     my $current_ci_level = $gnu_stack[$max_gnu_stack_index]->get_CI_LEVEL();
  5496.  
  5497.     my $type        = $types_to_go[$max_index_to_go];
  5498.     my $token       = $tokens_to_go[$max_index_to_go];
  5499.     my $total_depth = $nesting_depth_to_go[$max_index_to_go];
  5500.  
  5501.     if ( $type eq '{' || $type eq '(' ) {
  5502.  
  5503.         $gnu_comma_count{ $total_depth + 1 } = 0;
  5504.         $gnu_arrow_count{ $total_depth + 1 } = 0;
  5505.  
  5506.         # If we come to an opening token after an '=' token of some type,
  5507.         # see if it would be helpful to 'break' after the '=' to save space
  5508.         my $last_equals = $last_gnu_equals{$total_depth};
  5509.         if ( $last_equals && $last_equals > $line_start_index_to_go ) {
  5510.  
  5511.             # find the position if we break at the '='
  5512.             my $i_test = $last_equals;
  5513.             if ( $types_to_go[ $i_test + 1 ] eq 'b' ) { $i_test++ }
  5514.             my $test_position = total_line_length( $i_test, $max_index_to_go );
  5515.  
  5516.             if (
  5517.  
  5518.                 # if we are beyond the midpoint
  5519.                 $gnu_position_predictor > $half_maximum_line_length
  5520.  
  5521.                 # or if we can save some space by breaking at the '='
  5522.                 # without obscuring the second line by the first
  5523.                 || ( $test_position > 1 +
  5524.                     total_line_length( $line_start_index_to_go, $last_equals ) )
  5525.               )
  5526.             {
  5527.  
  5528.                 # then make the switch -- note that we do not set a real
  5529.                 # breakpoint here because we may not really need one; sub
  5530.                 # scan_list will do that if necessary
  5531.                 $line_start_index_to_go = $i_test + 1;
  5532.                 $gnu_position_predictor = $test_position;
  5533.             }
  5534.         }
  5535.     }
  5536.  
  5537.     # Check for decreasing depth ..
  5538.     # Note that one token may have both decreasing and then increasing
  5539.     # depth. For example, (level, ci) can go from (1,1) to (2,0).  So,
  5540.     # in this example we would first go back to (1,0) then up to (2,0)
  5541.     # in a single call.
  5542.     if ( $level < $current_level || $ci_level < $current_ci_level ) {
  5543.  
  5544.         # loop to find the first entry at or completely below this level
  5545.         my ( $lev, $ci_lev );
  5546.         while (1) {
  5547.             if ($max_gnu_stack_index) {
  5548.  
  5549.                 # save index of token which closes this level
  5550.                 $gnu_stack[$max_gnu_stack_index]->set_CLOSED($max_index_to_go);
  5551.  
  5552.                 # Undo any extra indentation if we saw no commas
  5553.                 my $available_spaces =
  5554.                   $gnu_stack[$max_gnu_stack_index]->get_AVAILABLE_SPACES();
  5555.  
  5556.                 my $comma_count = 0;
  5557.                 my $arrow_count = 0;
  5558.                 if ( $type eq '}' || $type eq ')' ) {
  5559.                     $comma_count = $gnu_comma_count{$total_depth};
  5560.                     $arrow_count = $gnu_arrow_count{$total_depth};
  5561.                     $comma_count = 0 unless $comma_count;
  5562.                     $arrow_count = 0 unless $arrow_count;
  5563.                 }
  5564.                 $gnu_stack[$max_gnu_stack_index]->set_COMMA_COUNT($comma_count);
  5565.                 $gnu_stack[$max_gnu_stack_index]->set_ARROW_COUNT($arrow_count);
  5566.  
  5567.                 if ( $available_spaces > 0 ) {
  5568.  
  5569.                     if ( $comma_count <= 0 || $arrow_count > 0 ) {
  5570.  
  5571.                         my $i = $gnu_stack[$max_gnu_stack_index]->get_INDEX();
  5572.                         my $seqno =
  5573.                           $gnu_stack[$max_gnu_stack_index]
  5574.                           ->get_SEQUENCE_NUMBER();
  5575.  
  5576.                         # Be sure this item was created in this batch.  This
  5577.                         # should be true because we delete any available
  5578.                         # space from open items at the end of each batch.
  5579.                         if (   $gnu_sequence_number != $seqno
  5580.                             || $i > $max_gnu_item_index )
  5581.                         {
  5582.                             warning(
  5583. "Program bug with -lp.  seqno=$seqno should be $gnu_sequence_number and i=$i should be less than max=$max_gnu_item_index\n"
  5584.                             );
  5585.                             report_definite_bug();
  5586.                         }
  5587.  
  5588.                         else {
  5589.                             if ( $arrow_count == 0 ) {
  5590.                                 $gnu_item_list[$i]
  5591.                                   ->permanently_decrease_AVAILABLE_SPACES(
  5592.                                     $available_spaces);
  5593.                             }
  5594.                             else {
  5595.                                 $gnu_item_list[$i]
  5596.                                   ->tentatively_decrease_AVAILABLE_SPACES(
  5597.                                     $available_spaces);
  5598.                             }
  5599.  
  5600.                             my $j;
  5601.                             for (
  5602.                                 $j = $i + 1 ;
  5603.                                 $j <= $max_gnu_item_index ;
  5604.                                 $j++
  5605.                               )
  5606.                             {
  5607.                                 $gnu_item_list[$j]
  5608.                                   ->decrease_SPACES($available_spaces);
  5609.                             }
  5610.                         }
  5611.                     }
  5612.                 }
  5613.  
  5614.                 # go down one level
  5615.                 --$max_gnu_stack_index;
  5616.                 $lev    = $gnu_stack[$max_gnu_stack_index]->get_LEVEL();
  5617.                 $ci_lev = $gnu_stack[$max_gnu_stack_index]->get_CI_LEVEL();
  5618.  
  5619.                 # stop when we reach a level at or below the current level
  5620.                 if ( $lev <= $level && $ci_lev <= $ci_level ) {
  5621.                     $space_count =
  5622.                       $gnu_stack[$max_gnu_stack_index]->get_SPACES();
  5623.                     $current_level    = $lev;
  5624.                     $current_ci_level = $ci_lev;
  5625.                     last;
  5626.                 }
  5627.             }
  5628.  
  5629.             # reached bottom of stack .. should never happen because
  5630.             # only negative levels can get here, and $level was forced
  5631.             # to be positive above.
  5632.             else {
  5633.                 warning(
  5634. "program bug with -lp: stack_error. level=$level; lev=$lev; ci_level=$ci_level; ci_lev=$ci_lev; rerun with -nlp\n"
  5635.                 );
  5636.                 report_definite_bug();
  5637.                 last;
  5638.             }
  5639.         }
  5640.     }
  5641.  
  5642.     # handle increasing depth
  5643.     if ( $level > $current_level || $ci_level > $current_ci_level ) {
  5644.  
  5645.         # Compute the standard incremental whitespace.  This will be
  5646.         # the minimum incremental whitespace that will be used.  This
  5647.         # choice results in a smooth transition between the gnu-style
  5648.         # and the standard style.
  5649.         my $standard_increment =
  5650.           ( $level - $current_level ) * $rOpts_indent_columns +
  5651.           ( $ci_level - $current_ci_level ) * $rOpts_continuation_indentation;
  5652.  
  5653.         # Now we have to define how much extra incremental space
  5654.         # ("$available_space") we want.  This extra space will be
  5655.         # reduced as necessary when long lines are encountered or when
  5656.         # it becomes clear that we do not have a good list.
  5657.         my $available_space = 0;
  5658.         my $align_paren     = 0;
  5659.         my $excess          = 0;
  5660.  
  5661.         # initialization on empty stack..
  5662.         if ( $max_gnu_stack_index == 0 ) {
  5663.             $space_count = $level * $rOpts_indent_columns;
  5664.         }
  5665.  
  5666.         # if this is a BLOCK, add the standard increment
  5667.         elsif ($last_nonblank_block_type) {
  5668.             $space_count += $standard_increment;
  5669.         }
  5670.  
  5671.         # if last nonblank token was not structural indentation,
  5672.         # just use standard increment
  5673.         elsif ( $last_nonblank_type ne '{' ) {
  5674.             $space_count += $standard_increment;
  5675.         }
  5676.  
  5677.         # otherwise use the space to the first non-blank level change token
  5678.         else {
  5679.  
  5680.             $space_count = $gnu_position_predictor;
  5681.  
  5682.             my $min_gnu_indentation =
  5683.               $gnu_stack[$max_gnu_stack_index]->get_SPACES();
  5684.  
  5685.             $available_space = $space_count - $min_gnu_indentation;
  5686.             if ( $available_space >= $standard_increment ) {
  5687.                 $min_gnu_indentation += $standard_increment;
  5688.             }
  5689.             elsif ( $available_space > 1 ) {
  5690.                 $min_gnu_indentation += $available_space + 1;
  5691.             }
  5692.             elsif ( $last_nonblank_token =~ /^[\{\[\(]$/ ) {
  5693.                 if ( ( $tightness{$last_nonblank_token} < 2 ) ) {
  5694.                     $min_gnu_indentation += 2;
  5695.                 }
  5696.                 else {
  5697.                     $min_gnu_indentation += 1;
  5698.                 }
  5699.             }
  5700.             else {
  5701.                 $min_gnu_indentation += $standard_increment;
  5702.             }
  5703.             $available_space = $space_count - $min_gnu_indentation;
  5704.  
  5705.             if ( $available_space < 0 ) {
  5706.                 $space_count     = $min_gnu_indentation;
  5707.                 $available_space = 0;
  5708.             }
  5709.             $align_paren = 1;
  5710.         }
  5711.  
  5712.         # update state, but not on a blank token
  5713.         if ( $types_to_go[$max_index_to_go] ne 'b' ) {
  5714.  
  5715.             $gnu_stack[$max_gnu_stack_index]->set_HAVE_CHILD(1);
  5716.  
  5717.             ++$max_gnu_stack_index;
  5718.             $gnu_stack[$max_gnu_stack_index] =
  5719.               new_lp_indentation_item( $space_count, $level, $ci_level,
  5720.                 $available_space, $align_paren );
  5721.  
  5722.             # If the opening paren is beyond the half-line length, then
  5723.             # we will use the minimum (standard) indentation.  This will
  5724.             # help avoid problems associated with running out of space
  5725.             # near the end of a line.  As a result, in deeply nested
  5726.             # lists, there will be some indentations which are limited
  5727.             # to this minimum standard indentation. But the most deeply
  5728.             # nested container will still probably be able to shift its
  5729.             # parameters to the right for proper alignment, so in most
  5730.             # cases this will not be noticable.
  5731.             if (   $available_space > 0
  5732.                 && $space_count > $half_maximum_line_length )
  5733.             {
  5734.                 $gnu_stack[$max_gnu_stack_index]
  5735.                   ->tentatively_decrease_AVAILABLE_SPACES($available_space);
  5736.             }
  5737.         }
  5738.     }
  5739.  
  5740.     # Count commas and look for non-list characters.  Once we see a
  5741.     # non-list character, we give up and don't look for any more commas.
  5742.     if ( $type eq '=>' ) {
  5743.         $gnu_arrow_count{$total_depth}++;
  5744.     }
  5745.  
  5746.     if ( $type eq ',' ) {
  5747.         $gnu_comma_count{$total_depth}++;
  5748.     }
  5749.  
  5750.     elsif ( $type =~ /=/ ) {
  5751.         $last_gnu_equals{$total_depth} = $max_index_to_go;
  5752.     }
  5753.  
  5754.     # this token might start a new line
  5755.     # if this is a non-blank..
  5756.     if ( $type ne 'b' ) {
  5757.  
  5758.         # and if ..
  5759.         if (
  5760.  
  5761.             # this is the first nonblank token of the line
  5762.             $max_index_to_go == 1 && $types_to_go[0] eq 'b'
  5763.  
  5764.             # or previous character was one of these:
  5765.             || $last_nonblank_type_to_go =~ /^([\:\?\,f])$/
  5766.  
  5767.             # or previous character was opening and this does not close it
  5768.             || ( $last_nonblank_type_to_go eq '{' && $type ne '}' )
  5769.             || ( $last_nonblank_type_to_go eq '(' and $type ne ')' )
  5770.  
  5771.             # or this token is one of these:
  5772.             || $type =~ /^([\.]|\|\||\&\&)$/
  5773.  
  5774.             # or this is a closing structure
  5775.             || (   $last_nonblank_type_to_go eq '}'
  5776.                 && $last_nonblank_token_to_go eq $last_nonblank_type_to_go )
  5777.  
  5778.             # or previous token was keyword 'return'
  5779.             || ( $last_nonblank_type_to_go eq 'k'
  5780.                 && ( $last_nonblank_token_to_go eq 'return' && $type ne '{' ) )
  5781.  
  5782.             # or starting a new line at certain keywords is fine
  5783.             || ( $type eq 'k'
  5784.                 && ( $token =~ /^(if|unless|and|or|last|next|redo|return)$/ ) )
  5785.  
  5786.             # or this is after an assignment after a closing structure
  5787.             || (
  5788.                    $last_nonblank_type_to_go =~ /=/
  5789.                 && $last_nonblank_type_to_go !~ /(==|!=|>=|<=|=~|=>)/
  5790.                 && (
  5791.                     $last_last_nonblank_type_to_go =~ /^[\}\)\]]$/
  5792.  
  5793.                     # and it is significantly to the right
  5794.                     || $gnu_position_predictor > $half_maximum_line_length
  5795.                 )
  5796.             )
  5797.           )
  5798.         {
  5799.             check_for_long_gnu_style_lines();
  5800.             $line_start_index_to_go = $max_index_to_go;
  5801.  
  5802.             # back up 1 token if we want to break before that type
  5803.             # otherwise, we may strand tokens like '?' or ':' on a line
  5804.             if ( $line_start_index_to_go > 0 ) {
  5805.                 if ( $last_nonblank_type_to_go eq 'k' ) {
  5806.                     if ( $last_nonblank_token_to_go =~ /^(and|or)$/ ) {
  5807.                         $line_start_index_to_go--;
  5808.                     }
  5809.                 }
  5810.                 elsif ( $want_break_before{$last_nonblank_type_to_go} ) {
  5811.                     $line_start_index_to_go--;
  5812.                 }
  5813.             }
  5814.         }
  5815.     }
  5816.  
  5817.     # remember the predicted position of this token on the output line
  5818.     if ( $max_index_to_go > $line_start_index_to_go ) {
  5819.         $gnu_position_predictor =
  5820.           total_line_length( $line_start_index_to_go, $max_index_to_go );
  5821.     }
  5822.     else {
  5823.         $gnu_position_predictor = $space_count +
  5824.           token_sequence_length( $max_index_to_go, $max_index_to_go );
  5825.     }
  5826.  
  5827.     # store the indentation object for this token
  5828.     # this allows us to manipulate the leading whitespace
  5829.     # (in case we have to reduce indentation to fit a line) without
  5830.     # having to change any token values
  5831.     $leading_spaces_to_go[$max_index_to_go] = $gnu_stack[$max_gnu_stack_index];
  5832.     $reduced_spaces_to_go[$max_index_to_go] =
  5833.       ( $max_gnu_stack_index > 0 && $ci_level )
  5834.       ? $gnu_stack[ $max_gnu_stack_index - 1 ]
  5835.       : $gnu_stack[$max_gnu_stack_index];
  5836.     return;
  5837. }
  5838.  
  5839. sub check_for_long_gnu_style_lines {
  5840.  
  5841.     # look at the current estimated maximum line length, and
  5842.     # remove some whitespace if it exceeds the desired maximum
  5843.  
  5844.     # this is only for the '-lp' style
  5845.     return unless ($rOpts_line_up_parentheses);
  5846.  
  5847.     # nothing can be done if no stack items defined for this line
  5848.     return if ( $max_gnu_item_index == UNDEFINED_INDEX );
  5849.  
  5850.     # see if we have exceeded the maximum desired line length
  5851.     # keep 2 extra free because they are needed in some cases
  5852.     # (result of trial-and-error testing)
  5853.     my $spaces_needed =
  5854.       $gnu_position_predictor - $rOpts_maximum_line_length + 2;
  5855.  
  5856.     return if ( $spaces_needed < 0 );
  5857.  
  5858.     # We are over the limit, so try to remove a requested number of
  5859.     # spaces from leading whitespace.  We are only allowed to remove
  5860.     # from whitespace items created on this batch, since others have
  5861.     # already been used and cannot be undone.
  5862.     my @candidates = ();
  5863.     my $i;
  5864.  
  5865.     # loop over all whitespace items created for the current batch
  5866.     for ( $i = 0 ; $i <= $max_gnu_item_index ; $i++ ) {
  5867.         my $item = $gnu_item_list[$i];
  5868.  
  5869.         # item must still be open to be a candidate (otherwise it
  5870.         # cannot influence the current token)
  5871.         next if ( $item->get_CLOSED() >= 0 );
  5872.  
  5873.         my $available_spaces = $item->get_AVAILABLE_SPACES();
  5874.  
  5875.         if ( $available_spaces > 0 ) {
  5876.             push ( @candidates, [ $i, $available_spaces ] );
  5877.         }
  5878.     }
  5879.  
  5880.     return unless (@candidates);
  5881.  
  5882.     # sort by available whitespace so that we can remove whitespace
  5883.     # from the maximum available first
  5884.     @candidates = sort { $b->[1] <=> $a->[1] } @candidates;
  5885.  
  5886.     # keep removing whitespace until we are done or have no more
  5887.     my $candidate;
  5888.     foreach $candidate (@candidates) {
  5889.         my ( $i, $available_spaces ) = @{$candidate};
  5890.         my $deleted_spaces =
  5891.           ( $available_spaces > $spaces_needed )
  5892.           ? $spaces_needed
  5893.           : $available_spaces;
  5894.  
  5895.         # remove the incremental space from this item
  5896.         $gnu_item_list[$i]->decrease_AVAILABLE_SPACES($deleted_spaces);
  5897.  
  5898.         my $i_debug = $i;
  5899.  
  5900.         # update the leading whitespace of this item and all items
  5901.         # that came after it
  5902.         for ( ; $i <= $max_gnu_item_index ; $i++ ) {
  5903.  
  5904.             my $old_spaces = $gnu_item_list[$i]->get_SPACES();
  5905.             if ( $old_spaces > $deleted_spaces ) {
  5906.                 $gnu_item_list[$i]->decrease_SPACES($deleted_spaces);
  5907.             }
  5908.  
  5909.             # shouldn't happen except for code bug:
  5910.             else {
  5911.                 my $level        = $gnu_item_list[$i_debug]->get_LEVEL();
  5912.                 my $ci_level     = $gnu_item_list[$i_debug]->get_CI_LEVEL();
  5913.                 my $old_level    = $gnu_item_list[$i]->get_LEVEL();
  5914.                 my $old_ci_level = $gnu_item_list[$i]->get_CI_LEVEL();
  5915.                 warning(
  5916. "program bug with -lp: want to delete $deleted_spaces from item $i, but old=$old_spaces deleted: lev=$level ci=$ci_level  deleted: level=$old_level ci=$ci_level\n"
  5917.                 );
  5918.                 report_definite_bug();
  5919.             }
  5920.         }
  5921.         $gnu_position_predictor -= $deleted_spaces;
  5922.         $spaces_needed          -= $deleted_spaces;
  5923.         last unless ( $spaces_needed > 0 );
  5924.     }
  5925. }
  5926.  
  5927. sub finish_lp_batch {
  5928.  
  5929.     # This routine is called once after each each output stream batch is
  5930.     # finished to undo indentation for all incomplete -lp
  5931.     # indentation levels.  It is too risky to leave a level open,
  5932.     # because then we can't backtrack in case of a long line to follow.
  5933.     # This means that comments and blank lines will disrupt this
  5934.     # indentation style.  But the vertical aligner may be able to
  5935.     # get the space back if there are side comments.
  5936.  
  5937.     # this is only for the 'lp' style
  5938.     return unless ($rOpts_line_up_parentheses);
  5939.  
  5940.     # nothing can be done if no stack items defined for this line
  5941.     return if ( $max_gnu_item_index == UNDEFINED_INDEX );
  5942.  
  5943.     # loop over all whitespace items created for the current batch
  5944.     my $i;
  5945.     for ( $i = 0 ; $i <= $max_gnu_item_index ; $i++ ) {
  5946.         my $item = $gnu_item_list[$i];
  5947.  
  5948.         # only look for open items
  5949.         next if ( $item->get_CLOSED() >= 0 );
  5950.  
  5951.         # Tentatively remove all of the available space
  5952.         # (The vertical aligner will try to get it back later)
  5953.         my $available_spaces = $item->get_AVAILABLE_SPACES();
  5954.         if ( $available_spaces > 0 ) {
  5955.  
  5956.             # delete incremental space for this item
  5957.             $gnu_item_list[$i]
  5958.               ->tentatively_decrease_AVAILABLE_SPACES($available_spaces);
  5959.  
  5960.             # Reduce the total indentation space of any nodes that follow
  5961.             # Note that any such nodes must necessarily be dependents
  5962.             # of this node.
  5963.             foreach ( $i + 1 .. $max_gnu_item_index ) {
  5964.                 $gnu_item_list[$_]->decrease_SPACES($available_spaces);
  5965.             }
  5966.         }
  5967.     }
  5968.     return;
  5969. }
  5970.  
  5971. sub reduce_lp_indentation {
  5972.  
  5973.     # reduce the leading whitespace at token $i if possible by $spaces_needed
  5974.     # (a large value of $spaces_needed will remove all excess space)
  5975.     # NOTE: to be called from scan_list only for a sequence of tokens
  5976.     # contained between opening and closing parens/braces/brackets
  5977.  
  5978.     my ( $i, $spaces_wanted ) = @_;
  5979.     my $deleted_spaces = 0;
  5980.  
  5981.     my $item             = $leading_spaces_to_go[$i];
  5982.     my $available_spaces = $item->get_AVAILABLE_SPACES();
  5983.  
  5984.     if (
  5985.         $available_spaces > 0
  5986.         && ( ( $spaces_wanted <= $available_spaces )
  5987.             || !$item->get_HAVE_CHILD() )
  5988.       )
  5989.     {
  5990.  
  5991.         # we'll remove these spaces, but mark them as recoverable
  5992.         $deleted_spaces =
  5993.           $item->tentatively_decrease_AVAILABLE_SPACES($spaces_wanted);
  5994.     }
  5995.  
  5996.     return $deleted_spaces;
  5997. }
  5998.  
  5999. sub token_sequence_length {
  6000.  
  6001.     # return length of tokens ($ifirst .. $ilast) including first & last
  6002.     # returns 0 if $ifirst > $ilast
  6003.     my $ifirst = shift;
  6004.     my $ilast  = shift;
  6005.     return 0 if ( $ilast < 0 || $ifirst > $ilast );
  6006.     return $lengths_to_go[ $ilast + 1 ] if ( $ifirst < 0 );
  6007.     return $lengths_to_go[ $ilast + 1 ] - $lengths_to_go[$ifirst];
  6008. }
  6009.  
  6010. sub total_line_length {
  6011.  
  6012.     # return length of a line of tokens ($ifirst .. $ilast)
  6013.     my $ifirst = shift;
  6014.     my $ilast  = shift;
  6015.     if ( $ifirst < 0 ) { $ifirst = 0 }
  6016.  
  6017.     return leading_spaces_to_go($ifirst) +
  6018.       token_sequence_length( $ifirst, $ilast );
  6019. }
  6020.  
  6021. sub excess_line_length {
  6022.  
  6023.     # return number of characters by which a line of tokens ($ifirst..$ilast)
  6024.     # exceeds the allowable line length.
  6025.     my $ifirst = shift;
  6026.     my $ilast  = shift;
  6027.     if ( $ifirst < 0 ) { $ifirst = 0 }
  6028.     return leading_spaces_to_go($ifirst) +
  6029.       token_sequence_length( $ifirst, $ilast ) - $rOpts_maximum_line_length;
  6030. }
  6031.  
  6032. sub finish_formatting {
  6033.  
  6034.     # flush buffer and write any informative messages
  6035.     my $self = shift;
  6036.  
  6037.     flush();
  6038.     $file_writer_object->decrement_output_line_number()
  6039.       ;    # fix up line number since it was incremented
  6040.     we_are_at_the_last_line();
  6041.     if ( $added_semicolon_count > 0 ) {
  6042.         my $first = ( $added_semicolon_count > 1 ) ? "First" : "";
  6043.         my $what =
  6044.           ( $added_semicolon_count > 1 ) ? "semicolons were" : "semicolon was";
  6045.         write_logfile_entry("$added_semicolon_count $what added:\n");
  6046.         write_logfile_entry(
  6047.             "  $first at input line $first_added_semicolon_at\n");
  6048.  
  6049.         if ( $added_semicolon_count > 1 ) {
  6050.             write_logfile_entry(
  6051.                 "   Last at input line $last_added_semicolon_at\n");
  6052.         }
  6053.         write_logfile_entry("  (Use -nasc to prevent semicolon addition)\n");
  6054.         write_logfile_entry("\n");
  6055.     }
  6056.  
  6057.     if ( $deleted_semicolon_count > 0 ) {
  6058.         my $first = ( $deleted_semicolon_count > 1 ) ? "First" : "";
  6059.         my $what =
  6060.           ( $deleted_semicolon_count > 1 )
  6061.           ? "semicolons were"
  6062.           : "semicolon was";
  6063.         write_logfile_entry(
  6064.             "$deleted_semicolon_count unnecessary $what deleted:\n");
  6065.         write_logfile_entry(
  6066.             "  $first at input line $first_deleted_semicolon_at\n");
  6067.  
  6068.         if ( $deleted_semicolon_count > 1 ) {
  6069.             write_logfile_entry(
  6070.                 "   Last at input line $last_deleted_semicolon_at\n");
  6071.         }
  6072.         write_logfile_entry("  (Use -ndsc to prevent semicolon deletion)\n");
  6073.         write_logfile_entry("\n");
  6074.     }
  6075.  
  6076.     if ( $embedded_tab_count > 0 ) {
  6077.         my $first = ( $embedded_tab_count > 1 ) ? "First" : "";
  6078.         my $what =
  6079.           ( $embedded_tab_count > 1 )
  6080.           ? "quotes or patterns"
  6081.           : "quote or pattern";
  6082.         write_logfile_entry("$embedded_tab_count $what had embedded tabs:\n");
  6083.         write_logfile_entry(
  6084. "This means the display of this script could vary with device or software\n"
  6085.         );
  6086.         write_logfile_entry("  $first at input line $first_embedded_tab_at\n");
  6087.  
  6088.         if ( $embedded_tab_count > 1 ) {
  6089.             write_logfile_entry(
  6090.                 "   Last at input line $last_embedded_tab_at\n");
  6091.         }
  6092.         write_logfile_entry("\n");
  6093.     }
  6094.  
  6095.     if ($first_tabbing_disagreement) {
  6096.         write_logfile_entry(
  6097. "First indentation disagreement seen at input line $first_tabbing_disagreement\n"
  6098.         );
  6099.     }
  6100.  
  6101.     if ($in_tabbing_disagreement) {
  6102.         write_logfile_entry(
  6103. "Ending with indentation disagreement which started at input line $in_tabbing_disagreement\n"
  6104.         );
  6105.     }
  6106.     else {
  6107.  
  6108.         if ($last_tabbing_disagreement) {
  6109.  
  6110.             write_logfile_entry(
  6111. "Last indentation disagreement seen at input line $last_tabbing_disagreement\n"
  6112.             );
  6113.         }
  6114.         else {
  6115.             write_logfile_entry("No indentation disagreement seen\n");
  6116.         }
  6117.     }
  6118.     write_logfile_entry("\n");
  6119.  
  6120.     $vertical_aligner_object->report_anything_unusual();
  6121.  
  6122.     $file_writer_object->report_line_length_errors();
  6123. }
  6124.  
  6125. sub check_options {
  6126.  
  6127.     # This routine is called to check the Opts hash after it is defined
  6128.  
  6129.     ($rOpts) = @_;
  6130.     my ( $tabbing_string, $tab_msg );
  6131.  
  6132.     make_static_block_comment_pattern();
  6133.     make_static_side_comment_pattern();
  6134.     make_closing_side_comment_prefix();
  6135.     make_closing_side_comment_list_pattern();
  6136.  
  6137.     # If closing side comments ARE selected, then we can safely
  6138.     # delete old closing side comments unless closing side comment
  6139.     # warnings are requested.  This is a good idea because it will
  6140.     # eliminate any old csc's which fall below the line count threshold.
  6141.     # We cannot do this if warnings are turned on, though, because we
  6142.     # might delete some text which has been added.  So that must
  6143.     # be handled when comments are created.
  6144.     if ( $rOpts->{'closing-side-comments'} ) {
  6145.         if ( !$rOpts->{'closing-side-comment-warnings'} ) {
  6146.             $rOpts->{'delete-closing-side-comments'} = 1;
  6147.         }
  6148.     }
  6149.  
  6150.     # If closing side comments ARE NOT selected, but warnings ARE
  6151.     # selected and we ARE DELETING csc's, then we will pretend to be
  6152.     # adding with a huge interval.  This will force the comments to be
  6153.     # generated for comparison with the old comments, but not added.
  6154.     elsif ( $rOpts->{'closing-side-comment-warnings'} ) {
  6155.         if ( $rOpts->{'delete-closing-side-comments'} ) {
  6156.             $rOpts->{'delete-closing-side-comments'}  = 0;
  6157.             $rOpts->{'closing-side-comments'}         = 1;
  6158.             $rOpts->{'closing-side-comment-interval'} = 100000000;
  6159.         }
  6160.     }
  6161.  
  6162.     make_bli_pattern();
  6163.     make_block_brace_vertical_tightness_pattern();
  6164.  
  6165.     if ( $rOpts->{'line-up-parentheses'} ) {
  6166.  
  6167.         if (   $rOpts->{'indent-only'}
  6168.             || !$rOpts->{'add-newlines'}
  6169.             || !$rOpts->{'delete-old-newlines'} )
  6170.         {
  6171.             warn <<EOM;
  6172. -----------------------------------------------------------------------
  6173. Conflict: -lp  conflicts with -io, -fnl, -nanl, or -ndnl; ignoring -lp
  6174.     
  6175. The -lp indentation logic requires that perltidy be able to coordinate
  6176. arbitrarily large numbers of line breakpoints.  This isn't possible
  6177. with these flags. Sometimes an acceptable workaround is to use -wocb=3
  6178. -----------------------------------------------------------------------
  6179. EOM
  6180.             $rOpts->{'line-up-parentheses'} = 0;
  6181.         }
  6182.     }
  6183.  
  6184.     # At present, tabs are not compatable with the line-up-parentheses style
  6185.     # (it would be possible to entab the total leading whitespace
  6186.     # just prior to writing the line, if desired).
  6187.     if ( $rOpts->{'line-up-parentheses'} && $rOpts->{'tabs'} ) {
  6188.         warn <<EOM;
  6189. Conflict: -t (tabs) cannot be used with the -lp  option; ignoring -t; see -et.
  6190. EOM
  6191.         $rOpts->{'tabs'} = 0;
  6192.     }
  6193.  
  6194.     # Likewise, tabs are not compatable with outdenting..
  6195.     if ( $rOpts->{'outdent-keywords'} && $rOpts->{'tabs'} ) {
  6196.         warn <<EOM;
  6197. Conflict: -t (tabs) cannot be used with the -okw options; ignoring -t; see -et.
  6198. EOM
  6199.         $rOpts->{'tabs'} = 0;
  6200.     }
  6201.  
  6202.     if ( $rOpts->{'outdent-labels'} && $rOpts->{'tabs'} ) {
  6203.         warn <<EOM;
  6204. Conflict: -t (tabs) cannot be used with the -ola  option; ignoring -t; see -et.
  6205. EOM
  6206.         $rOpts->{'tabs'} = 0;
  6207.     }
  6208.  
  6209.     if ( !$rOpts->{'space-for-semicolon'} ) {
  6210.         $want_left_space{'f'} = -1;
  6211.     }
  6212.  
  6213.     if ( $rOpts->{'space-terminal-semicolon'} ) {
  6214.         $want_left_space{';'} = 1;
  6215.     }
  6216.  
  6217.     # implement outdenting preferences for keywords
  6218.     %outdent_keyword = ();
  6219.  
  6220.     # load defaults
  6221.     @_ = qw(next last redo goto return);
  6222.  
  6223.     # override defaults if requested
  6224.     if ( $rOpts->{'outdent-keyword-list'} ) {
  6225.         $rOpts->{'outdent-keyword-list'} =~ s/^\s*//;
  6226.         $rOpts->{'outdent-keyword-list'} =~ s/\s*$//;
  6227.         @_ = split /\s+/, $rOpts->{'outdent-keyword-list'};
  6228.     }
  6229.  
  6230.     # FUTURE: if not a keyword, assume that it is an identifier
  6231.     foreach (@_) {
  6232.         if ( $Perl::Tidy::Tokenizer::is_keyword{$_} ) {
  6233.             $outdent_keyword{$_} = 1;
  6234.         }
  6235.         else {
  6236.             warn "ignoring '$_' in -okwl list; not a perl keyword";
  6237.         }
  6238.     }
  6239.  
  6240.     # implement user whitespace preferences
  6241.     if ( $rOpts->{'want-left-space'} ) {
  6242.         @_ = split /\s/, $rOpts->{'want-left-space'};
  6243.         @want_left_space{@_} = (1) x scalar(@_);
  6244.     }
  6245.  
  6246.     if ( $rOpts->{'want-right-space'} ) {
  6247.         @_ = split /\s/, $rOpts->{'want-right-space'};
  6248.         @want_right_space{@_} = (1) x scalar(@_);
  6249.     }
  6250.     if ( $rOpts->{'nowant-left-space'} ) {
  6251.         @_ = split /\s/, $rOpts->{'nowant-left-space'};
  6252.         @want_left_space{@_} = (-1) x scalar(@_);
  6253.     }
  6254.  
  6255.     if ( $rOpts->{'nowant-right-space'} ) {
  6256.         @_ = split /\s/, $rOpts->{'nowant-right-space'};
  6257.         @want_right_space{@_} = (-1) x scalar(@_);
  6258.     }
  6259.     if ( $rOpts->{'dump-want-left-space'} ) {
  6260.         dump_want_left_space(*STDOUT);
  6261.         exit 1;
  6262.     }
  6263.  
  6264.     if ( $rOpts->{'dump-want-right-space'} ) {
  6265.         dump_want_right_space(*STDOUT);
  6266.         exit 1;
  6267.     }
  6268.  
  6269.     # implement user break preferences
  6270.     if ( $rOpts->{'want-break-after'} ) {
  6271.         @_ = split /\s/, $rOpts->{'want-break-after'};
  6272.         foreach my $tok (@_) {
  6273.             if ( $tok eq '?' ) { $tok = ':' }    # patch to coordinate ?/:
  6274.             my $lbs = $left_bond_strength{$tok};
  6275.             my $rbs = $right_bond_strength{$tok};
  6276.             if ( defined($lbs) && defined($rbs) && $lbs < $rbs ) {
  6277.                 ( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
  6278.                   ( $lbs, $rbs );
  6279.             }
  6280.         }
  6281.     }
  6282.  
  6283.     if ( $rOpts->{'want-break-before'} ) {
  6284.         @_ = split /\s/, $rOpts->{'want-break-before'};
  6285.         foreach my $tok (@_) {
  6286.             my $lbs = $left_bond_strength{$tok};
  6287.             my $rbs = $right_bond_strength{$tok};
  6288.             if ( defined($lbs) && defined($rbs) && $rbs < $lbs ) {
  6289.                 ( $right_bond_strength{$tok}, $left_bond_strength{$tok} ) =
  6290.                   ( $lbs, $rbs );
  6291.             }
  6292.         }
  6293.     }
  6294.  
  6295.     # make note if breaks are before certain key types
  6296.     %want_break_before = ();
  6297.     foreach my $tok ( '.', ',', ':', '?', '&&', '||' ) {
  6298.         $want_break_before{$tok} =
  6299.           $left_bond_strength{$tok} < $right_bond_strength{$tok};
  6300.     }
  6301.  
  6302.     # Coordinate ?/: breaks, which must be similar
  6303.     if ( !$want_break_before{':'} ) {
  6304.         $want_break_before{'?'}   = $want_break_before{':'};
  6305.         $right_bond_strength{'?'} = $right_bond_strength{':'} + 0.01;
  6306.         $left_bond_strength{'?'}  = NO_BREAK;
  6307.     }
  6308.  
  6309.     # Define here tokens which may follow the closing brace of a do statement
  6310.     # on the same line, as in:
  6311.     #   } while ( $something);
  6312.     @_ = qw(until while unless if ; );
  6313.     push @_, ',';
  6314.     @is_do_follower{@_} = (1) x scalar(@_);
  6315.  
  6316.     # These tokens may follow the closing brace of an if or elsif block.
  6317.     # In other words, for cuddled else we want code to look like:
  6318.     #   } elsif ( $something) {
  6319.     #   } else {
  6320.     if ( $rOpts->{'cuddled-else'} ) {
  6321.         @_ = qw(else elsif);
  6322.         @is_if_brace_follower{@_} = (1) x scalar(@_);
  6323.     }
  6324.     else {
  6325.         %is_if_brace_follower = ();
  6326.     }
  6327.  
  6328.     # nothing can follow the closing curly of an else { } block:
  6329.     %is_else_brace_follower = ();
  6330.  
  6331.     # what can follow a multi-line anonymous sub definition closing curly:
  6332.     @_ = qw# ; : => or and  && || ) #;
  6333.     push @_, ',';
  6334.     @is_anon_sub_brace_follower{@_} = (1) x scalar(@_);
  6335.  
  6336.     # what can follow a one-line anonynomous sub closing curly:
  6337.     # one-line anonumous subs also have ']' here...
  6338.     # see tk3.t and PP.pm
  6339.     @_ = qw#  ; : => or and  && || ) ] #;
  6340.     push @_, ',';
  6341.     @is_anon_sub_1_brace_follower{@_} = (1) x scalar(@_);
  6342.  
  6343.     # What can follow a closing curly of a block
  6344.     # which is not an if/elsif/else/do/sort/map/grep/eval/sub
  6345.     # Testfiles: 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl'
  6346.     @_ = qw#  ; : => or and  && || ) #;
  6347.     push @_, ',';
  6348.  
  6349.     # allow cuddled continue if cuddled else is specified
  6350.     if ( $rOpts->{'cuddled-else'} ) { push @_, 'continue'; }
  6351.  
  6352.     @is_other_brace_follower{@_} = (1) x scalar(@_);
  6353.  
  6354.     $right_bond_strength{'{'} = WEAK;
  6355.     $left_bond_strength{'{'}  = VERY_STRONG;
  6356.  
  6357.     # make -l=0  equal to -l=infinite
  6358.     if ( !$rOpts->{'maximum-line-length'} ) {
  6359.         $rOpts->{'maximum-line-length'} = 1000000;
  6360.     }
  6361.  
  6362.     # make -lbl=0  equal to -lbl=infinite
  6363.     if ( !$rOpts->{'long-block-line-count'} ) {
  6364.         $rOpts->{'long-block-line-count'} = 1000000;
  6365.     }
  6366.  
  6367.     # hashes used to simplify setting whitespace
  6368.     %tightness = (
  6369.         '{' => $rOpts->{'brace-tightness'},
  6370.         '}' => $rOpts->{'brace-tightness'},
  6371.         '(' => $rOpts->{'paren-tightness'},
  6372.         ')' => $rOpts->{'paren-tightness'},
  6373.         '[' => $rOpts->{'square-bracket-tightness'},
  6374.         ']' => $rOpts->{'square-bracket-tightness'},
  6375.     );
  6376.     %matching_token = (
  6377.         '{' => '}',
  6378.         '(' => ')',
  6379.         '[' => ']',
  6380.         '?' => ':',
  6381.     );
  6382.  
  6383.     # frequently used parameters
  6384.     $rOpts_add_newlines                   = $rOpts->{'add-newlines'};
  6385.     $rOpts_add_whitespace                 = $rOpts->{'add-whitespace'};
  6386.     $rOpts_block_brace_tightness          = $rOpts->{'block-brace-tightness'};
  6387.     $rOpts_block_brace_vertical_tightness =
  6388.       $rOpts->{'block-brace-vertical-tightness'};
  6389.     $rOpts_brace_left_and_indent   = $rOpts->{'brace-left-and-indent'};
  6390.     $rOpts_comma_arrow_breakpoints = $rOpts->{'comma-arrow-breakpoints'};
  6391.     $rOpts_break_at_old_trinary_breakpoints =
  6392.       $rOpts->{'break-at-old-trinary-breakpoints'};
  6393.     $rOpts_break_at_old_comma_breakpoints =
  6394.       $rOpts->{'break-at-old-comma-breakpoints'};
  6395.     $rOpts_break_at_old_keyword_breakpoints =
  6396.       $rOpts->{'break-at-old-keyword-breakpoints'};
  6397.     $rOpts_break_at_old_logical_breakpoints =
  6398.       $rOpts->{'break-at-old-logical-breakpoints'};
  6399.     $rOpts_closing_side_comment_else_flag =
  6400.       $rOpts->{'closing-side-comment-else-flag'};
  6401.     $rOpts_closing_side_comment_maximum_text =
  6402.       $rOpts->{'closing-side-comment-maximum-text'};
  6403.     $rOpts_continuation_indentation = $rOpts->{'continuation-indentation'};
  6404.     $rOpts_cuddled_else             = $rOpts->{'cuddled-else'};
  6405.     $rOpts_delete_old_whitespace    = $rOpts->{'delete-old-whitespace'};
  6406.     $rOpts_fuzzy_line_length        = $rOpts->{'fuzzy-line-length'};
  6407.     $rOpts_indent_columns           = $rOpts->{'indent-columns'};
  6408.     $rOpts_line_up_parentheses      = $rOpts->{'line-up-parentheses'};
  6409.     $rOpts_maximum_fields_per_table = $rOpts->{'maximum-fields-per-table'};
  6410.     $rOpts_maximum_line_length      = $rOpts->{'maximum-line-length'};
  6411.     $rOpts_short_concatenation_item_length =
  6412.       $rOpts->{'short-concatenation-item-length'};
  6413.     $rOpts_swallow_optional_blank_lines =
  6414.       $rOpts->{'swallow-optional-blank-lines'};
  6415.     $rOpts_ignore_old_line_breaks = $rOpts->{'ignore-old-line-breaks'};
  6416.     $half_maximum_line_length     = $rOpts_maximum_line_length / 2;
  6417.  
  6418.     # Note that both opening and closing tokens can access the opening
  6419.     # and closing flags of their container types.
  6420.     %opening_vertical_tightness = (
  6421.         '(' => $rOpts->{'paren-vertical-tightness'},
  6422.         '{' => $rOpts->{'brace-vertical-tightness'},
  6423.         '[' => $rOpts->{'square-bracket-vertical-tightness'},
  6424.         ')' => $rOpts->{'paren-vertical-tightness'},
  6425.         '}' => $rOpts->{'brace-vertical-tightness'},
  6426.         ']' => $rOpts->{'square-bracket-vertical-tightness'},
  6427.     );
  6428.  
  6429.     %closing_vertical_tightness = (
  6430.         '(' => $rOpts->{'paren-vertical-tightness-closing'},
  6431.         '{' => $rOpts->{'brace-vertical-tightness-closing'},
  6432.         '[' => $rOpts->{'square-bracket-vertical-tightness-closing'},
  6433.         ')' => $rOpts->{'paren-vertical-tightness-closing'},
  6434.         '}' => $rOpts->{'brace-vertical-tightness-closing'},
  6435.         ']' => $rOpts->{'square-bracket-vertical-tightness-closing'},
  6436.     );
  6437. }
  6438.  
  6439. sub make_static_block_comment_pattern {
  6440.  
  6441.     # create the pattern used to identify static block comments
  6442.     $static_block_comment_pattern = '^(\s*)##';
  6443.  
  6444.     # allow the user to change it
  6445.     if ( $rOpts->{'static-block-comment-prefix'} ) {
  6446.         my $prefix = $rOpts->{'static-block-comment-prefix'};
  6447.         $prefix =~ s/^\s*//;
  6448.         if ( $prefix !~ /^#/ ) {
  6449.             die "ERROR: the -sbcp prefix '$prefix' must begin with '#'\n";
  6450.  
  6451.         }
  6452.         my $pattern = '^(\s*)' . $prefix;
  6453.         eval "'##'=~/$pattern/";
  6454.         if ($@) {
  6455.             die
  6456. "ERROR: the -sbc prefix '$prefix' causes the invalid regex '$pattern'\n";
  6457.         }
  6458.         $static_block_comment_pattern = $pattern;
  6459.     }
  6460. }
  6461.  
  6462. sub make_closing_side_comment_list_pattern {
  6463.  
  6464.     # turn any input list into a regex for recognizing selected block types
  6465.     $closing_side_comment_list_pattern = '^\w+';
  6466.     if ( defined( $rOpts->{'closing-side-comment-list'} )
  6467.         && $rOpts->{'closing-side-comment-list'} )
  6468.     {
  6469.         $closing_side_comment_list_pattern =
  6470.           make_block_pattern( '-cscl', $rOpts->{'closing-side-comment-list'} );
  6471.     }
  6472. }
  6473.  
  6474. sub make_bli_pattern {
  6475.  
  6476.     if (
  6477.         defined(
  6478.                  $rOpts->{'brace-left-and-indent-list'}
  6479.               && $rOpts->{'brace-left-and-indent-list'}
  6480.         )
  6481.       )
  6482.     {
  6483.         $bli_list_string = $rOpts->{'brace-left-and-indent-list'};
  6484.     }
  6485.  
  6486.     $bli_pattern = make_block_pattern( '-blil', $bli_list_string );
  6487. }
  6488.  
  6489. sub make_block_brace_vertical_tightness_pattern {
  6490.  
  6491.     # turn any input list into a regex for recognizing selected block types
  6492.     $block_brace_vertical_tightness_pattern =
  6493.       '^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
  6494.  
  6495.     if (
  6496.         defined(
  6497.                  $rOpts->{'block-brace-vertical-tightness-list'}
  6498.               && $rOpts->{'block-brace-vertical-tightness-list'}
  6499.         )
  6500.       )
  6501.     {
  6502.         $block_brace_vertical_tightness_pattern =
  6503.           make_block_pattern( '-bbvtl',
  6504.             $rOpts->{'block-brace-vertical-tightness-list'} );
  6505.     }
  6506. }
  6507.  
  6508. sub make_block_pattern {
  6509.  
  6510.     #  given a string of block-type keywords, return a regex to match them
  6511.     #  The only tricky part is that labels are indicated with a single ':'
  6512.     #  and the 'sub' token text may have additional text after it (name of
  6513.     #  sub).
  6514.     #
  6515.     #  Example:
  6516.     #
  6517.     #   input string: "if else elsif unless while for foreach do : sub";
  6518.     #   pattern:  '^((if|else|elsif|unless|while|for|foreach|do|\w+:)$|sub)';
  6519.  
  6520.     my ( $abbrev, $string ) = @_;
  6521.     $string =~ s/^\s*//;
  6522.     $string =~ s/\s$//;
  6523.     my @list = split /\s+/, $string;
  6524.     my @words = ();
  6525.     my %seen;
  6526.     for my $i (@list) {
  6527.         next if $seen{$i};
  6528.         $seen{$i} = 1;
  6529.         if ( $i eq 'sub' ) {
  6530.         }
  6531.         elsif ( $i eq ':' ) {
  6532.             push @words, '\w+:';
  6533.         }
  6534.         elsif ( $i =~ /^\w/ ) {
  6535.             push @words, $i;
  6536.         }
  6537.         else {
  6538.             warn "unrecognized block type $i after $abbrev, ignoring\n";
  6539.         }
  6540.     }
  6541.     my $pattern = '(' . join ( '|', @words ) . ')$';
  6542.     if ( $seen{'sub'} ) {
  6543.         $pattern = '(' . $pattern . '|sub)';
  6544.     }
  6545.     $pattern = '^' . $pattern;
  6546.     return $pattern;
  6547. }
  6548.  
  6549. sub make_static_side_comment_pattern {
  6550.  
  6551.     # create the pattern used to identify static side comments
  6552.     $static_side_comment_pattern = '^##';
  6553.  
  6554.     # allow the user to change it
  6555.     if ( $rOpts->{'static-side-comment-prefix'} ) {
  6556.         my $prefix = $rOpts->{'static-side-comment-prefix'};
  6557.         $prefix =~ s/^\s*//;
  6558.         my $pattern = '^' . $prefix;
  6559.         eval "'##'=~/$pattern/";
  6560.         if ($@) {
  6561.             die
  6562. "ERROR: the -sscp prefix '$prefix' causes the invalid regex '$pattern'\n";
  6563.         }
  6564.         $static_side_comment_pattern = $pattern;
  6565.     }
  6566. }
  6567.  
  6568. sub make_closing_side_comment_prefix {
  6569.  
  6570.     # Be sure we have a valid closing side comment prefix
  6571.     my $csc_prefix = $rOpts->{'closing-side-comment-prefix'};
  6572.     my $csc_prefix_pattern;
  6573.     if ( !defined($csc_prefix) ) {
  6574.         $csc_prefix         = '## end';
  6575.         $csc_prefix_pattern = '^##\s+end';
  6576.     }
  6577.     else {
  6578.         my $test_csc_prefix = $csc_prefix;
  6579.         if ( $test_csc_prefix !~ /^#/ ) {
  6580.             $test_csc_prefix = '#' . $test_csc_prefix;
  6581.         }
  6582.  
  6583.         # make a regex to recognize the prefix
  6584.         my $test_csc_prefix_pattern = $test_csc_prefix;
  6585.  
  6586.         # escape any special characters
  6587.         $test_csc_prefix_pattern =~ s/([^#\s\w])/\\$1/g;
  6588.  
  6589.         $test_csc_prefix_pattern = '^' . $test_csc_prefix_pattern;
  6590.  
  6591.         # allow exact number of intermediate spaces to vary
  6592.         $test_csc_prefix_pattern =~ s/\s+/\\s\+/g;
  6593.  
  6594.         # make sure we have a good pattern
  6595.         # if we fail this we probably have an error in escaping
  6596.         # characters.
  6597.         eval "'##'=~/$test_csc_prefix_pattern/";
  6598.         if ($@) {
  6599.  
  6600.             # shouldn't happen..must have screwed up escaping, above
  6601.             report_definite_bug();
  6602.             warn
  6603. "Program Error: the -cscp prefix '$csc_prefix' caused the invalid regex '$csc_prefix_pattern'\n";
  6604.  
  6605.             # just warn and keep going with defaults
  6606.             warn "Please consider using a simpler -cscp prefix\n";
  6607.             warn "Using default -cscp instead; please check output\n";
  6608.         }
  6609.         else {
  6610.             $csc_prefix         = $test_csc_prefix;
  6611.             $csc_prefix_pattern = $test_csc_prefix_pattern;
  6612.         }
  6613.     }
  6614.     $rOpts->{'closing-side-comment-prefix'} = $csc_prefix;
  6615.     $closing_side_comment_prefix_pattern = $csc_prefix_pattern;
  6616. }
  6617.  
  6618. sub dump_want_left_space {
  6619.     my $fh = shift;
  6620.     local $" = "\n";
  6621.     print $fh <<EOM;
  6622. These values are the main control of whitespace to the left of a token type;
  6623. They may be altered with the -wls parameter.
  6624. For a list of token types, use perltidy --dump-token-types (-dtt)
  6625.  1 means the token wants a space to its left
  6626. -1 means the token does not want a space to its left
  6627. ------------------------------------------------------------------------
  6628. EOM
  6629.     foreach ( sort keys %want_left_space ) {
  6630.         print $fh "$_\t$want_left_space{$_}\n";
  6631.     }
  6632. }
  6633.  
  6634. sub dump_want_right_space {
  6635.     my $fh = shift;
  6636.     local $" = "\n";
  6637.     print $fh <<EOM;
  6638. These values are the main control of whitespace to the right of a token type;
  6639. They may be altered with the -wrs parameter.
  6640. For a list of token types, use perltidy --dump-token-types (-dtt)
  6641.  1 means the token wants a space to its right
  6642. -1 means the token does not want a space to its right
  6643. ------------------------------------------------------------------------
  6644. EOM
  6645.     foreach ( sort keys %want_right_space ) {
  6646.         print $fh "$_\t$want_right_space{$_}\n";
  6647.     }
  6648. }
  6649.  
  6650. {    # begin is_essential_whitespace
  6651.  
  6652.     my %is_sort_grep_map;
  6653.     my %is_for_foreach;
  6654.  
  6655.     BEGIN {
  6656.  
  6657.         @_ = qw(sort grep map);
  6658.         @is_sort_grep_map{@_} = (1) x scalar(@_);
  6659.  
  6660.         @_ = qw(for foreach);
  6661.         @is_for_foreach{@_} = (1) x scalar(@_);
  6662.  
  6663.     }
  6664.  
  6665.     sub is_essential_whitespace {
  6666.  
  6667.         # Essential whitespace means whitespace which cannot be safely deleted.
  6668.         # We are given three tokens and their types:
  6669.         # ($tokenl, $typel) is the token to the left of the space in question
  6670.         # ($tokenr, $typer) is the token to the right of the space in question
  6671.         # ($tokenll, $typell) is previous nonblank token to the left of $tokenl
  6672.         #
  6673.         # This is a slow routine but is not needed too often except when -mangle
  6674.         # is used.
  6675.         my ( $tokenll, $typell, $tokenl, $typel, $tokenr, $typer ) = @_;
  6676.  
  6677.         # never combine two bare words or numbers
  6678.         my $result = ( ( $tokenr =~ /^[\'\w]/ ) && ( $tokenl =~ /[\'\w]$/ ) )
  6679.  
  6680.           # do not combine a number with a concatination dot
  6681.           # example: pom.caputo:
  6682.           # $vt100_compatible ? "\e[0;0H" : ('-' x 78 . "\n");
  6683.           || ( ( $typel eq 'n' ) && ( $tokenr eq '.' ) )
  6684.           || ( ( $typer eq 'n' ) && ( $tokenl eq '.' ) )
  6685.  
  6686.           # do not join a minus with a bare word, because you might form
  6687.           # a file test operator.  Example from Complex.pm:
  6688.           # if (CORE::abs($z - i) < $eps); "z-i" would be taken as a file test.
  6689.           || ( ( $tokenl eq '-' ) && ( $tokenr =~ /^[_A-Za-z]$/ ) )
  6690.  
  6691.           # and something like this could become ambiguous without space
  6692.           # after the '-':
  6693.           #   use constant III=>1;
  6694.           #   $a = $b - III;
  6695.           # and even this:
  6696.           #   $a = - III;
  6697.           || ( ( $tokenl eq '-' )
  6698.             && ( $typer =~ /^[wC]$/ && $tokenr =~ /^[_A-Za-z]/ ) )
  6699.  
  6700.           # '= -' should not become =- or you will get a warning
  6701.           # about reversed -=
  6702.           # || ($tokenr eq '-')
  6703.  
  6704.           # keep a space between a quote and a bareword to prevent the
  6705.           # bareword from becomming a quote modifier.
  6706.           || ( ( $typel eq 'Q' ) && ( $tokenr =~ /^[a-zA-Z_]/ ) )
  6707.  
  6708.           # keep a space between a token ending in '$' and any word;
  6709.           # this caused trouble:  "die @$ if $@"
  6710.           || ( ( $typel eq 'i' && $tokenl =~ /\$$/ )
  6711.             && ( $tokenr =~ /^[a-zA-Z_]/ ) )
  6712.  
  6713.           # perl is very fussy about spaces before <<
  6714.           || ( $tokenr =~ /^\<\</ )
  6715.  
  6716.           # avoid combining tokens to create new meanings. Example:
  6717.           #     $a+ +$b must not become $a++$b
  6718.           || ( $is_digraph{ $tokenl . $tokenr } )
  6719.           || ( $is_trigraph{ $tokenl . $tokenr } )
  6720.  
  6721.           # another example: do not combine these two &'s:
  6722.           #     allow_options & &OPT_EXECCGI
  6723.           || ( $is_digraph{ $tokenl . substr( $tokenr, 0, 1 ) } )
  6724.  
  6725.           # don't combine $$ or $# with any alphanumeric
  6726.           # (testfile mangle.t with --mangle)
  6727.           || ( ( $tokenl =~ /^\$[\$\#]$/ ) && ( $tokenr =~ /^\w/ ) )
  6728.  
  6729.           # retain any space after possible filehandle
  6730.           # (testfiles prnterr1.t with --extrude and mangle.t with --mangle)
  6731.           || ( $typel eq 'Z' || $typell eq 'Z' )
  6732.  
  6733.           # keep paren separate in 'use Foo::Bar ()'
  6734.           || ( $tokenr eq '('
  6735.             && $typel   eq 'w'
  6736.             && $typell  eq 'k'
  6737.             && $tokenll eq 'use' )
  6738.  
  6739.           # keep any space between filehandle and paren:
  6740.           # file mangle.t with --mangle:
  6741.           || ( $typel eq 'Y' && $tokenr eq '(' )
  6742.  
  6743.           # retain any space after here doc operator ( hereerr.t)
  6744.           || ( $typel eq 'h' )
  6745.  
  6746.           # FIXME: this needs some further work; extrude.t has test cases
  6747.           # it is safest to retain any space after start of ? : operator
  6748.           # because of perl's quirky parser.
  6749.           # ie, this line will fail if you remove the space after the '?':
  6750.           #    $b=join $comma ? ',' : ':', @_;   # ok
  6751.           #    $b=join $comma ?',' : ':', @_;   # error!
  6752.           # but this is ok :)
  6753.           #    $b=join $comma?',' : ':', @_;   # not a problem!
  6754.           ## || ($typel eq '?')
  6755.  
  6756.           # be careful with a space around ++ and --, to avoid ambiguity as to
  6757.           # which token it applies
  6758.           || ( ( $typer =~ /^(pp|mm)$/ )     && ( $tokenl !~ /^[\;\{\(\[]/ ) )
  6759.           || ( ( $typel =~ /^(\+\+|\-\-)$/ ) && ( $tokenr !~ /^[\;\}\)\]]/ ) )
  6760.  
  6761.           # need space after foreach my; for example, this will fail in
  6762.           # older versions of Perl:
  6763.           # foreach my$ft(@filetypes)...
  6764.           || (
  6765.             $tokenl eq 'my'
  6766.  
  6767.             #  /^(for|foreach)$/
  6768.             && $is_for_foreach{$tokenll} && $tokenr =~ /^\$/
  6769.           )
  6770.  
  6771.           # must have space between grep and left paren; "grep(" will fail
  6772.           #                       /^(sort|grep|map)$/
  6773.           || ( $tokenr eq '(' && $is_sort_grep_map{$tokenl} )
  6774.  
  6775.           # don't stick numbers next to left parens, as in:
  6776.           #use Mail::Internet 1.28 (); (see Entity.pm, Head.pm, Test.pm)
  6777.           || ( ( $typel eq 'n' ) && ( $tokenr eq '(' ) )
  6778.  
  6779.           # don't join something like: for bla::bla:: abc
  6780.           # example is "%overload:: and" in files Dumpvalue.pm or colonbug.pl
  6781.           || ( $tokenl =~ /\:\:$/ && ( $tokenr =~ /^[\'\w]/ ) )
  6782.           ;    # the value of this long logic sequence is the result we want
  6783.         return $result;
  6784.     }
  6785. }
  6786.  
  6787. sub set_white_space_flag {
  6788.  
  6789.     #    This routine examines each pair of nonblank tokens and
  6790.     #    sets values for array @white_space_flag.
  6791.     #
  6792.     #    $white_space_flag[$j] is a flag indicating whether a white space
  6793.     #    BEFORE token $j is needed, with the following values:
  6794.     #
  6795.     #            -1 do not want a space before token $j
  6796.     #             0 optional space or $j is a whitespace
  6797.     #             1 want a space before token $j
  6798.     #
  6799.     #
  6800.     #   The values for the first token will be defined based
  6801.     #   upon the contents of the "to_go" output array.
  6802.     #
  6803.     #   Note: retain debug print statements because they are usually
  6804.     #   required after adding new token types.
  6805.  
  6806.     BEGIN {
  6807.  
  6808.         # initialize these global hashes, which control the use of
  6809.         # whitespace around tokens:
  6810.         #
  6811.         # %binary_ws_rules
  6812.         # %want_left_space
  6813.         # %want_right_space
  6814.         # %space_before_paren
  6815.         #
  6816.         # Many token types are identical to the tokens themselves.
  6817.         # See the tokenizer for a complete list. Here are some special types:
  6818.         #   k = perl keyword
  6819.         #   f = semicolon in for statement
  6820.         #   m = unary minus
  6821.         #   p = unary plus
  6822.         # Note that :: is excluded since it should be contained in an identifier
  6823.         # Note that '->' is excluded because it never gets space
  6824.         # parentheses and brackets are excluded since they are handled specially
  6825.         # curly braces are included but may be overridden by logic, such as
  6826.         # newline logic.
  6827.  
  6828.         # NEW_TOKENS: create a whitespace rule here.  This can be as
  6829.         # simple as adding your new letter to @spaces_both_sides, for
  6830.         # example.
  6831.  
  6832.         @_ = qw" L { ( [ ";
  6833.         @is_opening_type{@_} = (1) x scalar(@_);
  6834.  
  6835.         @_ = qw" R } ) ] ";
  6836.         @is_closing_type{@_} = (1) x scalar(@_);
  6837.  
  6838.         my @spaces_both_sides = qw"
  6839.           + - * / % ? = . : x < > | & ^ .. << >> ** && .. ||  => += -=
  6840.           .= %= x= &= |= ^= *= <> <= >= == =~ !~ /= != ... <<= >>=
  6841.           &&= ||= <=> A k f w F n C Y U G v
  6842.           ";
  6843.  
  6844.         my @spaces_left_side = qw"
  6845.           t ! ~ m p { \ h pp mm Z j
  6846.           ";
  6847.         push ( @spaces_left_side, '#' );    # avoids warning message
  6848.  
  6849.         my @spaces_right_side = qw"
  6850.           ; } ) ] R J ++ -- **=
  6851.           ";
  6852.         push ( @spaces_right_side, ',' );    # avoids warning message
  6853.         my @space_before_paren = qw(
  6854.           my local and or eq ne if else elsif until unless while
  6855.           for foreach push return shift unshift pop join split die
  6856.         );
  6857.         @want_left_space{@spaces_both_sides} = (1) x scalar(@spaces_both_sides);
  6858.         @want_right_space{@spaces_both_sides} =
  6859.           (1) x scalar(@spaces_both_sides);
  6860.         @want_left_space{@spaces_left_side}  = (1) x scalar(@spaces_left_side);
  6861.         @want_right_space{@spaces_left_side} = (-1) x scalar(@spaces_left_side);
  6862.         @want_left_space{@spaces_right_side} =
  6863.           (-1) x scalar(@spaces_right_side);
  6864.         @want_right_space{@spaces_right_side} =
  6865.           (1) x scalar(@spaces_right_side);
  6866.         @space_before_paren{@space_before_paren} =
  6867.           (1) x scalar(@space_before_paren);
  6868.         $want_left_space{'L'}   = WS_NO;
  6869.         $want_left_space{'->'}  = WS_NO;
  6870.         $want_right_space{'->'} = WS_NO;
  6871.         $want_left_space{'**'}  = WS_NO;
  6872.         $want_right_space{'**'} = WS_NO;
  6873.  
  6874.         # hash type information must stay tightly bound
  6875.         # as in :  ${xxxx}
  6876.         $binary_ws_rules{'i'}{'L'} = WS_NO;
  6877.         $binary_ws_rules{'i'}{'{'} = WS_YES;
  6878.         $binary_ws_rules{'k'}{'{'} = WS_YES;
  6879.         $binary_ws_rules{'U'}{'{'} = WS_YES;
  6880.         $binary_ws_rules{'i'}{'['} = WS_NO;
  6881.         $binary_ws_rules{'R'}{'L'} = WS_NO;
  6882.         $binary_ws_rules{'R'}{'{'} = WS_NO;
  6883.         $binary_ws_rules{'t'}{'L'} = WS_NO;
  6884.         $binary_ws_rules{'t'}{'{'} = WS_NO;
  6885.         $binary_ws_rules{'}'}{'L'} = WS_NO;
  6886.         $binary_ws_rules{'}'}{'{'} = WS_NO;
  6887.         $binary_ws_rules{'$'}{'L'} = WS_NO;
  6888.         $binary_ws_rules{'$'}{'{'} = WS_NO;
  6889.         $binary_ws_rules{'@'}{'L'} = WS_NO;
  6890.         $binary_ws_rules{'@'}{'{'} = WS_NO;
  6891.         $binary_ws_rules{'='}{'L'} = WS_YES;
  6892.  
  6893.         # the following includes ') {'
  6894.         # as in :    if ( xxx ) { yyy }
  6895.         $binary_ws_rules{']'}{'L'} = WS_NO;
  6896.         $binary_ws_rules{']'}{'{'} = WS_NO;
  6897.         $binary_ws_rules{')'}{'{'} = WS_YES;
  6898.         $binary_ws_rules{')'}{'['} = WS_NO;
  6899.         $binary_ws_rules{']'}{'['} = WS_NO;
  6900.         $binary_ws_rules{']'}{'{'} = WS_NO;
  6901.         $binary_ws_rules{'}'}{'['} = WS_NO;
  6902.         $binary_ws_rules{'R'}{'['} = WS_NO;
  6903.  
  6904.         $binary_ws_rules{']'}{'++'} = WS_NO;
  6905.         $binary_ws_rules{']'}{'--'} = WS_NO;
  6906.         $binary_ws_rules{')'}{'++'} = WS_NO;
  6907.         $binary_ws_rules{')'}{'--'} = WS_NO;
  6908.  
  6909.         $binary_ws_rules{'R'}{'++'} = WS_NO;
  6910.         $binary_ws_rules{'R'}{'--'} = WS_NO;
  6911.  
  6912.         $binary_ws_rules{'k'}{':'} = WS_NO;     # keep colon with label
  6913.         $binary_ws_rules{'w'}{':'} = WS_NO;
  6914.         $binary_ws_rules{'i'}{'Q'} = WS_YES;
  6915.         $binary_ws_rules{'n'}{'('} = WS_YES;    # occurs in 'use package n ()'
  6916.  
  6917.         # FIXME: we need to split 'i' into variables and functions
  6918.         # and have no space for functions but space for variables.  For now,
  6919.         # I have a special patch in the special rules below
  6920.         $binary_ws_rules{'i'}{'('} = WS_NO;
  6921.  
  6922.         $binary_ws_rules{'w'}{'('} = WS_NO;
  6923.         $binary_ws_rules{'w'}{'{'} = WS_YES;
  6924.     }
  6925.     my ( $jmax, $rtokens, $rtoken_type, $rblock_type ) = @_;
  6926.     my ( $last_token, $last_type, $last_block_type, $token, $type,
  6927.         $block_type );
  6928.     my (@white_space_flag);
  6929.     my $j_tight_closing_paren = -1;
  6930.  
  6931.     if ( $max_index_to_go >= 0 ) {
  6932.         $token      = $tokens_to_go[$max_index_to_go];
  6933.         $type       = $types_to_go[$max_index_to_go];
  6934.         $block_type = $block_type_to_go[$max_index_to_go];
  6935.     }
  6936.     else {
  6937.         $token      = ' ';
  6938.         $type       = 'b';
  6939.         $block_type = '';
  6940.     }
  6941.  
  6942.     # loop over all tokens
  6943.     my ( $j, $ws );
  6944.  
  6945.     for ( $j = 0 ; $j <= $jmax ; $j++ ) {
  6946.  
  6947.         if ( $$rtoken_type[$j] eq 'b' ) {
  6948.             $white_space_flag[$j] = WS_OPTIONAL;
  6949.             next;
  6950.         }
  6951.  
  6952.         # set a default value, to be changed as needed
  6953.         $ws              = undef;
  6954.         $last_token      = $token;
  6955.         $last_type       = $type;
  6956.         $last_block_type = $block_type;
  6957.         $token           = $$rtokens[$j];
  6958.         $type            = $$rtoken_type[$j];
  6959.         $block_type      = $$rblock_type[$j];
  6960.  
  6961.         #---------------------------------------------------------------
  6962.         # section 1:
  6963.         # handle space on the inside of opening braces
  6964.         #---------------------------------------------------------------
  6965.  
  6966.         #    /^[L\{\(\[]$/
  6967.         if ( $is_opening_type{$last_type} ) {
  6968.  
  6969.             $j_tight_closing_paren = -1;
  6970.  
  6971.             # let's keep empty matched braces together: () {} []
  6972.             # except for BLOCKS
  6973.             if ( $token eq $matching_token{$last_token} ) {
  6974.                 if ($block_type) {
  6975.                     $ws = WS_YES;
  6976.                 }
  6977.                 else {
  6978.                     $ws = WS_NO;
  6979.                 }
  6980.             }
  6981.             else {
  6982.  
  6983.                 # we're considering the right of an opening brace
  6984.                 # tightness = 0 means always pad inside with space
  6985.                 # tightness = 1 means pad inside if "complex"
  6986.                 # tightness = 2 means never pad inside with space
  6987.  
  6988.                 my $tightness;
  6989.                 if (   $last_type eq '{'
  6990.                     && $last_token eq '{'
  6991.                     && $last_block_type )
  6992.                 {
  6993.                     $tightness = $rOpts_block_brace_tightness;
  6994.                 }
  6995.                 else { $tightness = $tightness{$last_token} }
  6996.  
  6997.                 if ( $tightness <= 0 ) {
  6998.                     $ws = WS_YES;
  6999.                 }
  7000.                 elsif ( $tightness > 1 ) {
  7001.                     $ws = WS_NO;
  7002.                 }
  7003.                 else {
  7004.                     my $j_next =
  7005.                       ( $$rtoken_type[ $j + 1 ] eq 'b' ) ? $j + 2 : $j + 1;
  7006.                     my $tok_next  = $$rtokens[$j_next];
  7007.                     my $type_next = $$rtoken_type[$j_next];
  7008.  
  7009.                     # for tightness = 1, if there is just one token
  7010.                     # within the matching pair, we will keep it tight
  7011.                     if (
  7012.                         $tok_next eq $matching_token{$last_token}
  7013.  
  7014.                         # but watch out for this: [ [ ]    (misc.t)
  7015.                         && $last_token ne $token
  7016.                       )
  7017.                     {
  7018.  
  7019.                         # remember where to put the space for the closing paren
  7020.                         $j_tight_closing_paren = $j_next;
  7021.                         $ws                    = WS_NO;
  7022.                     }
  7023.                     else {
  7024.                         $ws = WS_YES;
  7025.                     }
  7026.                 }
  7027.             }
  7028.         }    # done with opening braces and brackets
  7029.         my $ws_1 = $ws
  7030.           if FORMATTER_DEBUG_FLAG_WHITE;
  7031.  
  7032.         #---------------------------------------------------------------
  7033.         # section 2:
  7034.         # handle space on inside of closing brace pairs
  7035.         #---------------------------------------------------------------
  7036.  
  7037.         #   /[\}\)\]R]/
  7038.         if ( $is_closing_type{$type} ) {
  7039.  
  7040.             if ( $j == $j_tight_closing_paren ) {
  7041.  
  7042.                 $j_tight_closing_paren = -1;
  7043.                 $ws                    = WS_NO;
  7044.             }
  7045.             else {
  7046.  
  7047.                 if ( !defined($ws) ) {
  7048.  
  7049.                     my $tightness;
  7050.                     if ( $type eq '}' && $token eq '}' && $block_type ) {
  7051.                         $tightness = $rOpts_block_brace_tightness;
  7052.                     }
  7053.                     else { $tightness = $tightness{$token} }
  7054.  
  7055.                     $ws = ( $tightness > 1 ) ? WS_NO : WS_YES;
  7056.                 }
  7057.             }
  7058.         }
  7059.  
  7060.         my $ws_2 = $ws
  7061.           if FORMATTER_DEBUG_FLAG_WHITE;
  7062.  
  7063.         #---------------------------------------------------------------
  7064.         # section 3:
  7065.         # use the binary table
  7066.         #---------------------------------------------------------------
  7067.         if ( !defined($ws) ) {
  7068.             $ws = $binary_ws_rules{$last_type}{$type};
  7069.         }
  7070.         my $ws_3 = $ws
  7071.           if FORMATTER_DEBUG_FLAG_WHITE;
  7072.  
  7073.         #---------------------------------------------------------------
  7074.         # section 4:
  7075.         # some special cases
  7076.         #---------------------------------------------------------------
  7077.         if ( $token eq '(' ) {
  7078.  
  7079.             # This will have to be tweaked as tokenization changes.
  7080.             # We want a space after certain block types:
  7081.             #     map { 1 * $_; } ( $y, $M, $w, $d, $h, $m, $s );
  7082.             #
  7083.             # But not others:
  7084.             #     &{ $_->[1] } ( delete $_[$#_]{ $_->[0] } );
  7085.             # At present, the & block is not marked as a code block, so
  7086.             # this works:
  7087.             if ( $last_type eq '}' ) {
  7088.  
  7089.                 # /^(sort|map|grep)$/
  7090.                 if ( $is_sort_map_grep{$last_block_type} ) {
  7091.                     $ws = WS_YES;
  7092.                 }
  7093.                 else {
  7094.                     $ws = WS_NO;
  7095.                 }
  7096.             }
  7097.  
  7098.             # -----------------------------------------------------
  7099.             # 'w' and 'i' checks for something like:
  7100.             #   myfun(    &myfun(   ->myfun(
  7101.             # -----------------------------------------------------
  7102.             if (   ( $last_type =~ /^[wkU]$/ )
  7103.                 || ( $last_type eq 'i' && $last_token =~ /^(\&|->)/ ) )
  7104.             {
  7105.  
  7106.                 # Do not introduce new space between keyword or function
  7107.                 # and ( except in special cases) because this can
  7108.                 # introduce errors in some cases ( prnterr1.t )
  7109.                 unless ( $space_before_paren{$last_token} ) {
  7110.                     $ws = WS_NO;
  7111.                 }
  7112.             }
  7113.  
  7114.             # space between something like $i and ( in
  7115.             # for $i ( 0 .. 20 ) {
  7116.             # FIXME: eventually, type 'i' needs to be split into multiple
  7117.             # token types so this can be a hardwired rule.
  7118.             elsif ( $last_type eq 'i' && $last_token =~ /^[\$\%\@]/ ) {
  7119.                 $ws = WS_YES;
  7120.             }
  7121.  
  7122.             # allow constant function followed by '()' to retain no space
  7123.             elsif ( $last_type eq 'C' && $$rtokens[ $j + 1 ] eq ')' ) {
  7124.                 ;
  7125.                 $ws = WS_NO;
  7126.             }
  7127.         }
  7128.  
  7129.         # patch for SWITCH/CASE: make space at ']{' optional
  7130.         # since the '{' might begin a case or when block
  7131.         elsif ( $token eq '{' && $last_token eq ']' ) {
  7132.             $ws = WS_OPTIONAL;
  7133.         }
  7134.  
  7135.         # keep space between 'sub' and '{' for anonymous sub definition
  7136.         if ( $type eq '{' ) {
  7137.             if ( $last_token eq 'sub' ) {
  7138.                 $ws = WS_YES;
  7139.             }
  7140.  
  7141.             # this is needed to avoid no space in '){'
  7142.             if ( $last_token eq ')' && $token eq '{' ) { $ws = WS_YES }
  7143.  
  7144.             # avoid any space before the brace or bracket in something like
  7145.             #  @opts{'a','b',...}
  7146.             if ( $last_type eq 'i' && $last_token =~ /^\@/ ) {
  7147.                 $ws = WS_NO;
  7148.             }
  7149.         }
  7150.  
  7151.         elsif ( $type eq 'i' ) {
  7152.  
  7153.             # never a space before ->
  7154.             if ( $token =~ /^\-\>/ ) {
  7155.                 $ws = WS_NO;
  7156.             }
  7157.         }
  7158.  
  7159.         # retain any space between '-' and bare word
  7160.         elsif ( $type eq 'w' || $type eq 'C' ) {
  7161.             $ws = WS_OPTIONAL if $last_type eq '-';
  7162.         }
  7163.  
  7164.         # retain any space between '-' and bare word
  7165.         # example: avoid space between 'USER' and '-' here:
  7166.         #   $myhash{USER-NAME}='steve';
  7167.         elsif ( $type eq 'm' || $type eq '-' ) {
  7168.             $ws = WS_OPTIONAL if ( $last_type eq 'w' );
  7169.         }
  7170.  
  7171.         # always space before side comment
  7172.         elsif ( $type eq '#' ) { $ws = WS_YES if $j > 0 }
  7173.  
  7174.         # always preserver whatever space was used after a possible
  7175.         # filehandle or here doc operator
  7176.         if ( $type ne '#' && ( $last_type eq 'Z' || $last_type eq 'h' ) ) {
  7177.             $ws = WS_OPTIONAL;
  7178.         }
  7179.  
  7180.         my $ws_4 = $ws
  7181.           if FORMATTER_DEBUG_FLAG_WHITE;
  7182.  
  7183.         #---------------------------------------------------------------
  7184.         # section 5:
  7185.         # default rules not covered above
  7186.         #---------------------------------------------------------------
  7187.         # if we fall through to here,
  7188.         # look at the pre-defined hash tables for the two tokens, and
  7189.         # if (they are equal) use the common value
  7190.         # if (either is zero or undef) use the other
  7191.         # if (either is -1) use it
  7192.         # That is,
  7193.         # left  vs right
  7194.         #  1    vs    1     -->  1
  7195.         #  0    vs    0     -->  0
  7196.         # -1    vs   -1     --> -1
  7197.         #
  7198.         #  0    vs   -1     --> -1
  7199.         #  0    vs    1     -->  1
  7200.         #  1    vs    0     -->  1
  7201.         # -1    vs    0     --> -1
  7202.         #
  7203.         # -1    vs    1     --> -1
  7204.         #  1    vs   -1     --> -1
  7205.         if ( !defined($ws) ) {
  7206.             my $wl = $want_left_space{$type};
  7207.             my $wr = $want_right_space{$last_type};
  7208.             if ( !defined($wl) ) { $wl = 0 }
  7209.             if ( !defined($wr) ) { $wr = 0 }
  7210.             $ws = ( ( $wl == $wr ) || ( $wl == -1 ) || !$wr ) ? $wl : $wr;
  7211.         }
  7212.  
  7213.         if ( !defined($ws) ) {
  7214.             $ws = 0;
  7215.             write_diagnostics(
  7216.                 "WS flag is undefined for tokens $last_token $token\n");
  7217.         }
  7218.  
  7219.         # Treat newline as a whitespace. Otherwise, we might combine
  7220.         # 'Send' and '-recipients' here according to the above rules:
  7221.         #    my $msg = new Fax::Send
  7222.         #      -recipients => $to,
  7223.         #      -data => $data;
  7224.         if ( $ws == 0 && $j == 0 ) { $ws = 1 }
  7225.  
  7226.         if (   ( $ws == 0 )
  7227.             && $j > 0
  7228.             && $j < $jmax
  7229.             && ( $last_type !~ /^[Zh]$/ ) )
  7230.         {
  7231.  
  7232.             # If this happens, we have a non-fatal but undesirable
  7233.             # hole in the above rules which should be patched.
  7234.             write_diagnostics(
  7235.                 "WS flag is zero for tokens $last_token $token\n");
  7236.         }
  7237.         $white_space_flag[$j] = $ws;
  7238.  
  7239.         FORMATTER_DEBUG_FLAG_WHITE && do {
  7240.             my $str = substr( $last_token, 0, 15 );
  7241.             $str .= ' ' x ( 16 - length($str) );
  7242.             if ( !defined($ws_1) ) { $ws_1 = "*" }
  7243.             if ( !defined($ws_2) ) { $ws_2 = "*" }
  7244.             if ( !defined($ws_3) ) { $ws_3 = "*" }
  7245.             if ( !defined($ws_4) ) { $ws_4 = "*" }
  7246.             print
  7247. "WHITE:  i=$j $str $last_type $type $ws_1 : $ws_2 : $ws_3 : $ws_4 : $ws \n";
  7248.         };
  7249.     }
  7250.     return \@white_space_flag;
  7251. }
  7252.  
  7253. {    # begin print_line_of_tokens
  7254.  
  7255.     my $rtoken_type;
  7256.     my $rtokens;
  7257.     my $rlevels;
  7258.     my $rslevels;
  7259.     my $rblock_type;
  7260.     my $rcontainer_type;
  7261.     my $rcontainer_environment;
  7262.     my $rtype_sequence;
  7263.     my $input_line;
  7264.     my $rnesting_tokens;
  7265.     my $rci_levels;
  7266.     my $rnesting_blocks;
  7267.  
  7268.     my $in_quote;
  7269.     my $python_indentation_level;
  7270.  
  7271.     # These local token variables are stored by store_token_to_go:
  7272.     my $block_type;
  7273.     my $ci_level;
  7274.     my $container_environment;
  7275.     my $container_type;
  7276.     my $in_continued_quote;
  7277.     my $level;
  7278.     my $nesting_blocks;
  7279.     my $no_internal_newlines;
  7280.     my $slevel;
  7281.     my $token;
  7282.     my $type;
  7283.     my $type_sequence;
  7284.  
  7285.     # routine to pull the jth token from the line of tokens
  7286.     sub extract_token {
  7287.         my $j = shift;
  7288.         $token                 = $$rtokens[$j];
  7289.         $type                  = $$rtoken_type[$j];
  7290.         $block_type            = $$rblock_type[$j];
  7291.         $container_type        = $$rcontainer_type[$j];
  7292.         $container_environment = $$rcontainer_environment[$j];
  7293.         $type_sequence         = $$rtype_sequence[$j];
  7294.         $level                 = $$rlevels[$j];
  7295.         $slevel                = $$rslevels[$j];
  7296.         $nesting_blocks        = $$rnesting_blocks[$j];
  7297.         $ci_level              = $$rci_levels[$j];
  7298.     }
  7299.  
  7300.     {
  7301.         my @saved_token;
  7302.  
  7303.         sub save_current_token {
  7304.  
  7305.             @saved_token = (
  7306.                 $block_type,            $ci_level,
  7307.                 $container_environment, $container_type,
  7308.                 $in_continued_quote,    $level,
  7309.                 $nesting_blocks,        $no_internal_newlines,
  7310.                 $slevel,                $token,
  7311.                 $type,                  $type_sequence,
  7312.             );
  7313.         }
  7314.  
  7315.         sub restore_current_token {
  7316.             (
  7317.                 $block_type,            $ci_level,
  7318.                 $container_environment, $container_type,
  7319.                 $in_continued_quote,    $level,
  7320.                 $nesting_blocks,        $no_internal_newlines,
  7321.                 $slevel,                $token,
  7322.                 $type,                  $type_sequence,
  7323.               )
  7324.               = @saved_token;
  7325.         }
  7326.     }
  7327.  
  7328.     # Routine to place the current token into the output stream.
  7329.     # Called once per output token.
  7330.     sub store_token_to_go {
  7331.  
  7332.         my $flag = $no_internal_newlines;
  7333.         if ( $_[0] ) { $flag = 1 }
  7334.  
  7335.         $tokens_to_go[ ++$max_index_to_go ]            = $token;
  7336.         $types_to_go[$max_index_to_go]                 = $type;
  7337.         $nobreak_to_go[$max_index_to_go]               = $flag;
  7338.         $old_breakpoint_to_go[$max_index_to_go]        = 0;
  7339.         $forced_breakpoint_to_go[$max_index_to_go]     = 0;
  7340.         $block_type_to_go[$max_index_to_go]            = $block_type;
  7341.         $type_sequence_to_go[$max_index_to_go]         = $type_sequence;
  7342.         $container_environment_to_go[$max_index_to_go] = $container_environment;
  7343.         $nesting_blocks_to_go[$max_index_to_go]        = $nesting_blocks;
  7344.         $ci_levels_to_go[$max_index_to_go]             = $ci_level;
  7345.         $mate_index_to_go[$max_index_to_go]            = -1;
  7346.         $matching_token_to_go[$max_index_to_go]        = '';
  7347.  
  7348.         # Note: negative levels are currently retained as a diagnostic so that
  7349.         # the 'final indentation level' is correctly reported for bad scripts.
  7350.         # But this means that every use of $level as an index must be checked.
  7351.         # If this becomes too much of a problem, we might give up and just clip
  7352.         # them at zero.
  7353.         ## $levels_to_go[$max_index_to_go] = ( $level > 0 ) ? $level : 0;
  7354.         $levels_to_go[$max_index_to_go]        = $level;
  7355.         $nesting_depth_to_go[$max_index_to_go] = ( $slevel >= 0 ) ? $slevel : 0;
  7356.         $lengths_to_go[ $max_index_to_go + 1 ] =
  7357.           $lengths_to_go[$max_index_to_go] + length($token);
  7358.  
  7359.         # Define the indentation that this token would have if it started
  7360.         # a new line.  We have to do this now because we need to know this
  7361.         # when considering one-line blocks.
  7362.         set_leading_whitespace( $level, $ci_level, $in_continued_quote );
  7363.  
  7364.         if ( $type ne 'b' ) {
  7365.             $last_last_nonblank_index_to_go = $last_nonblank_index_to_go;
  7366.             $last_last_nonblank_type_to_go  = $last_nonblank_type_to_go;
  7367.             $last_last_nonblank_token_to_go = $last_nonblank_token_to_go;
  7368.             $last_nonblank_index_to_go      = $max_index_to_go;
  7369.             $last_nonblank_type_to_go       = $type;
  7370.             $last_nonblank_token_to_go      = $token;
  7371.             if ( $type eq ',' ) {
  7372.                 $comma_count_in_batch++;
  7373.             }
  7374.         }
  7375.  
  7376.         FORMATTER_DEBUG_FLAG_STORE && do {
  7377.             my ( $a, $b, $c ) = caller();
  7378.             print
  7379. "STORE: from $a $c: storing token $token type $type lev=$level slev=$slevel at $max_index_to_go\n";
  7380.         };
  7381.     }
  7382.  
  7383.     sub insert_new_token_to_go {
  7384.  
  7385.         # insert a new token into the output stream.  use same level as
  7386.         # previous token; assumes a character at max_index_to_go.
  7387.         save_current_token();
  7388.         ( $token, $type, $slevel, $no_internal_newlines ) = @_;
  7389.  
  7390.         if ( $max_index_to_go == UNDEFINED_INDEX ) {
  7391.             warning("code bug: bad call to insert_new_token_to_go\n");
  7392.         }
  7393.         $level = $levels_to_go[$max_index_to_go];
  7394.  
  7395.         # FIXME: it seems to be necessary to use the next, rather than
  7396.         # previous, value of this variable when creating a new blank (align.t)
  7397.         #my $slevel         = $nesting_depth_to_go[$max_index_to_go];
  7398.         $nesting_blocks        = $nesting_blocks_to_go[$max_index_to_go];
  7399.         $ci_level              = $ci_levels_to_go[$max_index_to_go];
  7400.         $container_environment = $container_environment_to_go[$max_index_to_go];
  7401.         $in_continued_quote    = 0;
  7402.         $block_type            = "";
  7403.         $type_sequence         = "";
  7404.         store_token_to_go();
  7405.         restore_current_token();
  7406.         return;
  7407.     }
  7408.  
  7409.     my %is_until_while_for_if_elsif_else;
  7410.  
  7411.     BEGIN {
  7412.  
  7413.         # always break after a closing curly of these block types:
  7414.         @_ = qw(until while for if elsif else);
  7415.         @is_until_while_for_if_elsif_else{@_} = (1) x scalar(@_);
  7416.  
  7417.     }
  7418.  
  7419.     sub print_line_of_tokens {
  7420.  
  7421.         my $line_of_tokens = shift;
  7422.  
  7423.         # This routine is called once per input line to process all of
  7424.         # the tokens on that line.  This is the first stage of
  7425.         # beautification.
  7426.         #
  7427.         # Full-line comments and blank lines may be processed immediately.
  7428.         #
  7429.         # For normal lines of code, the tokens are stored one-by-one,
  7430.         # via calls to 'sub store_token_to_go', until a known line break
  7431.         # point is reached.  Then, the batch of collected tokens is
  7432.         # passed along to 'sub output_line_to_go' for further
  7433.         # processing.  This routine decides if there should be
  7434.         # whitespace between each pair of non-white tokens, so later
  7435.         # routines only need to decide on any additional line breaks.
  7436.         # Any whitespace is initally a single space character.  Later,
  7437.         # the vertical aligner may expand that to be multiple space
  7438.         # characters if necessary for alignment.
  7439.  
  7440.         # extract input line number for error messages
  7441.         $input_line_number = $line_of_tokens->{_line_number};
  7442.  
  7443.         $rtoken_type            = $line_of_tokens->{_rtoken_type};
  7444.         $rtokens                = $line_of_tokens->{_rtokens};
  7445.         $rlevels                = $line_of_tokens->{_rlevels};
  7446.         $rslevels               = $line_of_tokens->{_rslevels};
  7447.         $rblock_type            = $line_of_tokens->{_rblock_type};
  7448.         $rcontainer_type        = $line_of_tokens->{_rcontainer_type};
  7449.         $rcontainer_environment = $line_of_tokens->{_rcontainer_environment};
  7450.         $rtype_sequence         = $line_of_tokens->{_rtype_sequence};
  7451.         $input_line             = $line_of_tokens->{_line_text};
  7452.         $rnesting_tokens        = $line_of_tokens->{_rnesting_tokens};
  7453.         $rci_levels             = $line_of_tokens->{_rci_levels};
  7454.         $rnesting_blocks        = $line_of_tokens->{_rnesting_blocks};
  7455.  
  7456.         $in_continued_quote       = $line_of_tokens->{_starting_in_quote};
  7457.         $in_quote                 = $line_of_tokens->{_ending_in_quote};
  7458.         $python_indentation_level =
  7459.           $line_of_tokens->{_python_indentation_level};
  7460.  
  7461.         my $j;
  7462.         my $j_next;
  7463.         my $jmax;
  7464.         my $next_nonblank_token;
  7465.         my $next_nonblank_token_type;
  7466.         my $rwhite_space_flag;
  7467.  
  7468.         $jmax                  = @$rtokens - 1;
  7469.         $block_type            = "";
  7470.         $container_type        = "";
  7471.         $container_environment = "";
  7472.         $type_sequence         = "";
  7473.         $no_internal_newlines  = 1 - $rOpts_add_newlines;
  7474.  
  7475.         # Handle a continued quote..
  7476.         if ($in_continued_quote) {
  7477.  
  7478.             # A line which is entirely a quote or pattern must go out
  7479.             # verbatim.  Note: the \n is contained in $input_line.
  7480.             if ( $jmax <= 0 ) {
  7481.                 if ( ( $input_line =~ "\t" ) ) {
  7482.                     note_embedded_tab();
  7483.                 }
  7484.                 write_unindented_line("$input_line");
  7485.                 $last_line_had_side_comment = 0;
  7486.                 return;
  7487.             }
  7488.  
  7489.             # prior to version 20010406, perltidy had a bug which placed
  7490.             # continuation indentation before the last line of some multiline
  7491.             # quotes and patterns -- exactly the lines passing this way.
  7492.             # To help find affected lines in scripts run with these
  7493.             # versions, run with '-chk', and it will warn of any quotes or
  7494.             # patterns which might have been modified by these early
  7495.             # versions.
  7496.             if ( $rOpts->{'check-multiline-quotes'} && $input_line =~ /^ / ) {
  7497.                 warning(
  7498. "-chk: please check this line for extra leading whitespace\n"
  7499.                 );
  7500.             }
  7501.         }
  7502.  
  7503.         # delete trailing blank tokens
  7504.         if ( $jmax > 0 && $$rtoken_type[$jmax] eq 'b' ) { $jmax-- }
  7505.  
  7506.         # Handle a blank line..
  7507.         if ( $jmax < 0 ) {
  7508.  
  7509.             # For the 'swallow-optional-blank-lines' option, we delete all
  7510.             # old blank lines and let the blank line rules generate any
  7511.             # needed blanks.
  7512.             if ( !$rOpts_swallow_optional_blank_lines ) {
  7513.                 flush();
  7514.                 $file_writer_object->write_blank_code_line();
  7515.                 $last_line_leading_type = 'b';
  7516.             }
  7517.             $last_line_had_side_comment = 0;
  7518.             return;
  7519.         }
  7520.  
  7521.         # see if this is a static block comment (starts with ##)
  7522.         my $is_static_block_comment                       = 0;
  7523.         my $is_static_block_comment_without_leading_space = 0;
  7524.         if (   $jmax == 0
  7525.             && $$rtoken_type[0] eq '#'
  7526.             && $rOpts->{'static-block-comments'}
  7527.             && $input_line =~ /$static_block_comment_pattern/o )
  7528.         {
  7529.             $is_static_block_comment                       = 1;
  7530.             $is_static_block_comment_without_leading_space =
  7531.               ( length($1) <= 0 );
  7532.         }
  7533.  
  7534.         # create a hanging side comment if appropriate
  7535.         if (
  7536.                $jmax == 0
  7537.             && $$rtoken_type[0] eq '#'    # only token is a comment
  7538.             && $last_line_had_side_comment    # last line had side comment
  7539.             && $input_line =~ /^\s/           # there is some leading space
  7540.             && !$is_static_block_comment    # do not make static comment hanging
  7541.             && $rOpts->{'hanging-side-comments'}    # user is allowing this
  7542.           )
  7543.         {
  7544.  
  7545.             # We will insert an empty qw string at the start of the token list
  7546.             # to force this comment to be a side comment. The vertical aligner
  7547.             # should then line it up with the previous side comment.
  7548.             unshift @$rtoken_type,            'q';
  7549.             unshift @$rtokens,                '';
  7550.             unshift @$rlevels,                $$rlevels[0];
  7551.             unshift @$rslevels,               $$rslevels[0];
  7552.             unshift @$rblock_type,            '';
  7553.             unshift @$rcontainer_type,        '';
  7554.             unshift @$rcontainer_environment, '';
  7555.             unshift @$rtype_sequence,         '';
  7556.             unshift @$rnesting_tokens,        $$rnesting_tokens[0];
  7557.             unshift @$rci_levels,             $$rci_levels[0];
  7558.             unshift @$rnesting_blocks,        $$rnesting_blocks[0];
  7559.             $jmax = 1;
  7560.         }
  7561.  
  7562.         # remember if this line has a side comment
  7563.         $last_line_had_side_comment =
  7564.           ( $jmax > 0 && $$rtoken_type[$jmax] eq '#' );
  7565.  
  7566.         # Handle a block (full-line) comment..
  7567.         if ( ( $jmax == 0 ) && ( $$rtoken_type[0] eq '#' ) ) {
  7568.  
  7569.             if ( $rOpts->{'delete-block-comments'} ) { return }
  7570.  
  7571.             if ( $rOpts->{'tee-block-comments'} ) {
  7572.                 $file_writer_object->tee_on();
  7573.             }
  7574.  
  7575.             destroy_one_line_block();
  7576.             output_line_to_go();
  7577.  
  7578.             # output a blank line before block comments
  7579.             if (
  7580.                    $last_line_leading_type !~ /^[#b]$/
  7581.                 && $rOpts->{'blanks-before-comments'}    # only if allowed
  7582.                 && !
  7583.                 $is_static_block_comment    # never before static block comments
  7584.               )
  7585.             {
  7586.                 flush();                    # switching to new output stream
  7587.                 $file_writer_object->write_blank_code_line();
  7588.                 $last_line_leading_type = 'b';
  7589.             }
  7590.  
  7591.             # TRIM COMMENTS -- This could be turned off as a option
  7592.             $$rtokens[0] =~ s/\s*$//;       # trim right end
  7593.  
  7594.             if (
  7595.                 $rOpts->{'indent-block-comments'}
  7596.                 && ( !$rOpts->{'indent-spaced-block-comments'}
  7597.                     || $input_line =~ /^\s+/ )
  7598.                 && !$is_static_block_comment_without_leading_space
  7599.               )
  7600.             {
  7601.                 extract_token(0);
  7602.                 store_token_to_go();
  7603.                 output_line_to_go();
  7604.             }
  7605.             else {
  7606.                 flush();    # switching to new output stream
  7607.                 $file_writer_object->write_code_line( $$rtokens[0] . "\n" );
  7608.                 $last_line_leading_type = '#';
  7609.             }
  7610.             if ( $rOpts->{'tee-block-comments'} ) {
  7611.                 $file_writer_object->tee_off();
  7612.             }
  7613.             return;
  7614.         }
  7615.  
  7616.         # compare input/output indentation except for continuation lines
  7617.         # (because they have an unknown amount of initial blank space)
  7618.         # and lines which are quotes (because they may have been outdented)
  7619.         # Note: this test is placed here because we know the continuation flag
  7620.         # at this point, which allows us to avoid non-meaningful checks.
  7621.         my $structural_indentation_level = $$rlevels[0];
  7622.         compare_indentation_levels( $python_indentation_level,
  7623.             $structural_indentation_level )
  7624.           unless ( $python_indentation_level < 0
  7625.             || ( $$rci_levels[0] > 0 )
  7626.             || ( ( $python_indentation_level == 0 ) && $$rtoken_type[0] eq 'Q' )
  7627.           );
  7628.  
  7629.         #   Patch needed for MakeMaker.  Do not break a statement
  7630.         #   in which $VERSION may be calculated.  See MakeMaker.pm;
  7631.         #   this is based on the coding in it.
  7632.         #   The first line of a file that matches this will be eval'd:
  7633.         #       /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
  7634.         #   Examples:
  7635.         #     *VERSION = \'1.01';
  7636.         #     ( $VERSION ) = '$Revision: 1.36 $ ' =~ /\$Revision:\s+([^\s]+)/;
  7637.         #   We will pass such a line straight through without breaking
  7638.         #   it unless -npvl is used
  7639.  
  7640.         my $is_VERSION_statement = 0;
  7641.  
  7642.         if (
  7643.             !$saw_VERSION_in_this_file
  7644.             && $input_line =~ /VERSION/    # quick check to reject most lines
  7645.             && $input_line =~ /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/
  7646.           )
  7647.         {
  7648.             $saw_VERSION_in_this_file = 1;
  7649.             $is_VERSION_statement     = 1;
  7650.             write_logfile_entry("passing VERSION line; -npvl deactivates\n");
  7651.             $no_internal_newlines = 1;
  7652.         }
  7653.  
  7654.         # take care of indentation-only
  7655.         # also write a line which is entirely a 'qw' list
  7656.         if ( $rOpts->{'indent-only'}
  7657.             || ( ( $jmax == 0 ) && ( $$rtoken_type[0] eq 'q' ) ) )
  7658.         {
  7659.             flush();
  7660.             $input_line =~ s/^\s*//;    # trim left end
  7661.             $input_line =~ s/\s*$//;    # trim right end
  7662.  
  7663.             extract_token(0);
  7664.             $token                 = $input_line;
  7665.             $type                  = 'q';
  7666.             $block_type            = "";
  7667.             $container_type        = "";
  7668.             $container_environment = "";
  7669.             $type_sequence         = "";
  7670.             store_token_to_go();
  7671.             output_line_to_go();
  7672.             return;
  7673.         }
  7674.  
  7675.         push ( @$rtokens,     ' ', ' ' );  # making $j+2 valid simplifies coding
  7676.         push ( @$rtoken_type, 'b', 'b' );
  7677.         ($rwhite_space_flag) =
  7678.           set_white_space_flag( $jmax, $rtokens, $rtoken_type, $rblock_type );
  7679.  
  7680.         # find input tabbing to allow checks for tabbing disagreement
  7681.         ## not used for now
  7682.         ##$input_line_tabbing = "";
  7683.         ##if ( $input_line =~ /^(\s*)/ ) { $input_line_tabbing = $1; }
  7684.  
  7685.         # if the buffer hasn't been flushed, add a leading space if
  7686.         # necessary to keep essential whitespace. This is really only
  7687.         # necessary if we are squeezing out all ws.
  7688.         if ( $max_index_to_go >= 0 ) {
  7689.  
  7690.             $old_line_count_in_batch++;
  7691.  
  7692.             if (
  7693.                 is_essential_whitespace(
  7694.                     $last_last_nonblank_token,
  7695.                     $last_last_nonblank_type,
  7696.                     $tokens_to_go[$max_index_to_go],
  7697.                     $types_to_go[$max_index_to_go],
  7698.                     $$rtokens[0],
  7699.                     $$rtoken_type[0]
  7700.                 )
  7701.               )
  7702.             {
  7703.                 my $slevel = $$rslevels[0];
  7704.                 insert_new_token_to_go( ' ', 'b', $slevel,
  7705.                     $no_internal_newlines );
  7706.             }
  7707.         }
  7708.  
  7709.         # If we just saw the end of an elsif block, write nag message
  7710.         # if we do not see another elseif or an else.
  7711.         if ($looking_for_else) {
  7712.  
  7713.             unless ( $$rtokens[0] =~ /^(elsif|else)$/ ) {
  7714.                 write_logfile_entry("(No else block)\n");
  7715.             }
  7716.             $looking_for_else = 0;
  7717.         }
  7718.  
  7719.         # This is a good place to kill incomplete one-line blocks
  7720.         if (   ( $semicolons_before_block_self_destruct == 0 )
  7721.             && ( $max_index_to_go >= 0 )
  7722.             && ( $types_to_go[$max_index_to_go] eq ';' )
  7723.             && ( $$rtokens[0] ne '}' ) )
  7724.         {
  7725.             destroy_one_line_block();
  7726.             output_line_to_go();
  7727.         }
  7728.  
  7729.         # loop to process the tokens one-by-one
  7730.         $type  = 'b';
  7731.         $token = "";
  7732.  
  7733.         foreach $j ( 0 .. $jmax ) {
  7734.  
  7735.             # pull out the local values for this token
  7736.             extract_token($j);
  7737.  
  7738.             if ( $type eq '#' ) {
  7739.  
  7740.                 # trim trailing whitespace
  7741.                 # (there is no option at present to prevent this)
  7742.                 $token =~ s/\s*$//;
  7743.  
  7744.                 if (
  7745.                     $rOpts->{'delete-side-comments'}
  7746.  
  7747.                     # delete closing side comments if necessary
  7748.                     || (   $rOpts->{'delete-closing-side-comments'}
  7749.                         && $token =~ /$closing_side_comment_prefix_pattern/o
  7750.                         && $last_nonblank_block_type =~
  7751.                         /$closing_side_comment_list_pattern/o )
  7752.                   )
  7753.                 {
  7754.                     if ( $types_to_go[$max_index_to_go] eq 'b' ) {
  7755.                         unstore_token_to_go();
  7756.                     }
  7757.                     last;
  7758.                 }
  7759.             }
  7760.  
  7761.             # If we are continuing after seeing a right curly brace, flush
  7762.             # buffer unless we see what we are looking for, as in
  7763.             #   } else ...
  7764.             if ( $rbrace_follower && $type ne 'b' ) {
  7765.  
  7766.                 unless ( $rbrace_follower->{$token} ) {
  7767.                     output_line_to_go();
  7768.                 }
  7769.                 $rbrace_follower = undef;
  7770.             }
  7771.  
  7772.             $j_next = ( $$rtoken_type[ $j + 1 ] eq 'b' ) ? $j + 2 : $j + 1;
  7773.             $next_nonblank_token      = $$rtokens[$j_next];
  7774.             $next_nonblank_token_type = $$rtoken_type[$j_next];
  7775.  
  7776.             #--------------------------------------------------------
  7777.             # Start of section to patch token text
  7778.             #--------------------------------------------------------
  7779.  
  7780.             # Modify certain tokens here for whitespace
  7781.             # The following is not yet done, but could be:
  7782.             #   sub (x x x)
  7783.             # These become type 'i', space and all.
  7784.             if ( $type eq 'i' or $type eq 't' ) {
  7785.  
  7786.                 # change "$  var"  to "$var" etc
  7787.                 if ( $token =~ /^([\$\&\%\*\@]|\-\>)\s/ ) {
  7788.                     $token =~ s/\s*//g;
  7789.                 }
  7790.  
  7791.                 if ( $token =~ /^sub/ ) { $token =~ s/\s+/ /g }
  7792.             }
  7793.  
  7794.             # change 'LABEL   :'   to 'LABEL:'
  7795.             elsif ( $type eq 'J' ) { $token =~ s/\s+//g }
  7796.  
  7797.             # patch to add space to something like "x10"
  7798.             # This avoids having to split this token in the pre-tokenizer
  7799.             elsif ( $type eq 'n' ) {
  7800.                 if ( $token =~ /^x\d+/ ) { $token =~ s/x/x / }
  7801.             }
  7802.  
  7803.             elsif ( $type eq 'Q' ) {
  7804.                 note_embedded_tab() if ( $token =~ "\t" );
  7805.  
  7806.                 # make note of something like '$var = s/xxx/yyy/;'
  7807.                 # in case it should have been '$var =~ s/xxx/yyy/;'
  7808.                 if (
  7809.                        $token               =~ /^(s|tr|y|m|\/)/
  7810.                     && $last_nonblank_token =~ /^(=|==|!=)$/
  7811.  
  7812.                     # precededed by simple scalar
  7813.                     && $last_last_nonblank_type eq 'i'
  7814.                     && $last_last_nonblank_token =~ /^\$/
  7815.  
  7816.                     # followed by some kind of termination
  7817.                     # (but give complaint if we can's see far enough ahead)
  7818.                     && $next_nonblank_token =~ /^[; \)\}]$/
  7819.  
  7820.                     # scalar is not decleared
  7821.                     && !(
  7822.                            $types_to_go[0] eq 'k'
  7823.                         && $tokens_to_go[0] =~ /^(my|our|local)$/
  7824.                     )
  7825.                   )
  7826.                 {
  7827.                     my $guess = substr( $last_nonblank_token, 0, 1 ) . '~';
  7828.                     complain(
  7829. "Note: be sure you want '$last_nonblank_token' instead of '$guess' here\n"
  7830.                     );
  7831.                 }
  7832.             }
  7833.  
  7834.            # trim blanks from right of qw quotes
  7835.            # (To avoid trimming qw quotes use -ntqw; the tokenizer handles this)
  7836.             elsif ( $type eq 'q' ) {
  7837.                 $token =~ s/\s*$//;
  7838.                 note_embedded_tab() if ( $token =~ "\t" );
  7839.             }
  7840.  
  7841.             #--------------------------------------------------------
  7842.             # End of section to patch token text
  7843.             #--------------------------------------------------------
  7844.  
  7845.             # insert any needed whitespace
  7846.             if (   ( $type ne 'b' )
  7847.                 && ( $max_index_to_go >= 0 )
  7848.                 && ( $types_to_go[$max_index_to_go] ne 'b' )
  7849.                 && $rOpts_add_whitespace )
  7850.             {
  7851.                 my $ws = $$rwhite_space_flag[$j];
  7852.  
  7853.                 if ( $ws == 1 ) {
  7854.                     insert_new_token_to_go( ' ', 'b', $slevel,
  7855.                         $no_internal_newlines );
  7856.                 }
  7857.             }
  7858.  
  7859.             # Do not allow breaks which would promote a side comment to a
  7860.             # block comment.  In order to allow a break before an opening
  7861.             # or closing BLOCK, followed by a side comment, those sections
  7862.             # of code will handle this flag separately.
  7863.             my $side_comment_follows = ( $next_nonblank_token_type eq '#' );
  7864.             my $is_opening_BLOCK =
  7865.               (      $type eq '{'
  7866.                   && $token eq '{'
  7867.                   && $block_type
  7868.                   && $block_type ne 't' );
  7869.             my $is_closing_BLOCK =
  7870.               (      $type eq '}'
  7871.                   && $token eq '}'
  7872.                   && $block_type
  7873.                   && $block_type ne 't' );
  7874.  
  7875.             if (   $side_comment_follows
  7876.                 && !$is_opening_BLOCK
  7877.                 && !$is_closing_BLOCK )
  7878.             {
  7879.                 $no_internal_newlines = 1;
  7880.             }
  7881.  
  7882.             # We're only going to handle breaking for code BLOCKS at this
  7883.             # (top) level.  Other indentation breaks will be handled by
  7884.             # sub scan_list, which is better suited to dealing with them.
  7885.             if ($is_opening_BLOCK) {
  7886.  
  7887.                 # Tentatively output this token.  This is required before
  7888.                 # calling starting_one_line_block.  We may have to unstore
  7889.                 # it, though, if we have to break before it.
  7890.                 store_token_to_go($side_comment_follows);
  7891.  
  7892.                 # Look ahead to see if we might form a one-line block
  7893.                 my $too_long =
  7894.                   starting_one_line_block( $j, $jmax, $level, $slevel,
  7895.                     $ci_level, $rtokens, $rtoken_type, $rblock_type );
  7896.                 clear_breakpoint_undo_stack();
  7897.  
  7898.                 # to simplify the logic below, set a flag to indicate if
  7899.                 # this opening brace is far from the keyword which introduces it
  7900.                 my $keyword_on_same_line = 1;
  7901.                 if (   ( $max_index_to_go >= 0 )
  7902.                     && ( $last_nonblank_type eq ')' ) )
  7903.                 {
  7904.                     if (   $block_type =~ /^(if|else|elsif)$/
  7905.                         && ( $tokens_to_go[0] eq '}' )
  7906.                         && $rOpts_cuddled_else )
  7907.                     {
  7908.                         $keyword_on_same_line = 1;
  7909.                     }
  7910.                     elsif ( ( $slevel < $nesting_depth_to_go[0] ) || $too_long )
  7911.                     {
  7912.                         $keyword_on_same_line = 0;
  7913.                     }
  7914.                 }
  7915.  
  7916.                 # decide if user requested break before '{'
  7917.                 my $want_break =
  7918.  
  7919.                   # use -bl flag if not a sub block of any type
  7920.                   $block_type !~ /^sub/
  7921.                   ? $rOpts->{'opening-brace-on-new-line'}
  7922.  
  7923.                   # use -sbl flag unless this is an anonymous sub block
  7924.                   : $block_type !~ /^sub\W*$/
  7925.                   ? $rOpts->{'opening-sub-brace-on-new-line'}
  7926.  
  7927.                   # do not break for anonymous subs
  7928.                   : 0;
  7929.  
  7930.                 # Break before an opening '{' ...
  7931.                 if (
  7932.  
  7933.                     # if requested
  7934.                     $want_break
  7935.  
  7936.                     # and we were unable to start looking for a block,
  7937.                     && $index_start_one_line_block == UNDEFINED_INDEX
  7938.  
  7939.                     # or if it will not be on same line as its keyword, so that
  7940.                     # it will be outdented (eval.t, overload.t), and the user
  7941.                     # has not insisted on keeping it on the right
  7942.                     || (   !$keyword_on_same_line
  7943.                         && !$rOpts->{'opening-brace-always-on-right'} )
  7944.  
  7945.                   )
  7946.                 {
  7947.  
  7948.                     # but only if allowed
  7949.                     unless ($no_internal_newlines) {
  7950.  
  7951.                         # since we already stored this token, we must unstore it
  7952.                         unstore_token_to_go();
  7953.  
  7954.                         # then output the line
  7955.                         output_line_to_go();
  7956.  
  7957.                         # and now store this token at the start of a new line
  7958.                         store_token_to_go($side_comment_follows);
  7959.                     }
  7960.                 }
  7961.  
  7962.                 # Now update for side comment
  7963.                 if ($side_comment_follows) { $no_internal_newlines = 1 }
  7964.  
  7965.                 # now output this line
  7966.                 unless ($no_internal_newlines) {
  7967.                     output_line_to_go();
  7968.                 }
  7969.             }
  7970.  
  7971.             elsif ($is_closing_BLOCK) {
  7972.  
  7973.                 # If there is a pending one-line block ..
  7974.                 if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
  7975.  
  7976.                     # we have to terminate it if..
  7977.                     if (
  7978.  
  7979.                     # it is too long (final length may be different from
  7980.                     # initial estimate). note: must allow 1 space for this token
  7981.                         excess_line_length( $index_start_one_line_block,
  7982.                             $max_index_to_go ) >= 0
  7983.  
  7984.                         # or if it has too many semicolons
  7985.                         || (   $semicolons_before_block_self_destruct == 0
  7986.                             && $last_nonblank_type ne ';' )
  7987.                       )
  7988.                     {
  7989.                         destroy_one_line_block();
  7990.                     }
  7991.                 }
  7992.  
  7993.                 # put a break before this closing curly brace if appropriate
  7994.                 unless ( $no_internal_newlines
  7995.                     || $index_start_one_line_block != UNDEFINED_INDEX )
  7996.                 {
  7997.  
  7998.                     # add missing semicolon if ...
  7999.                     # there are some tokens
  8000.                     if (
  8001.                         ( $max_index_to_go > 0 )
  8002.  
  8003.                         # and we don't have one
  8004.                         && ( $last_nonblank_type ne ';' )
  8005.  
  8006.                         # patch until some block type issues are fixed:
  8007.                         # Do not add semi-colon for block types '{',
  8008.                         # '}', and ';' because we cannot be sure yet
  8009.                         # that this is a block and not an anonomyous
  8010.                         # hash (blktype.t, blktype1.t)
  8011.                         && ( $block_type !~ /^[\{\};]$/ )
  8012.  
  8013.                         # it seems best not to add semicolons in these
  8014.                         # special block types:
  8015.                         #     /^(sort|map|grep)$/
  8016.                         && ( !$is_sort_map_grep{$block_type} )
  8017.  
  8018.                         # and we are allowed to do so.
  8019.                         && $rOpts->{'add-semicolons'}
  8020.                       )
  8021.                     {
  8022.  
  8023.                         save_current_token();
  8024.                         $token  = ';';
  8025.                         $type   = ';';
  8026.                         $level  = $levels_to_go[$max_index_to_go];
  8027.                         $slevel = $nesting_depth_to_go[$max_index_to_go];
  8028.                         $nesting_blocks =
  8029.                           $nesting_blocks_to_go[$max_index_to_go];
  8030.                         $ci_level       = $ci_levels_to_go[$max_index_to_go];
  8031.                         $block_type     = "";
  8032.                         $container_type = "";
  8033.                         $container_environment = "";
  8034.                         $type_sequence         = "";
  8035.  
  8036.                         # Note - we remove any blank AFTER extracting its
  8037.                         # parameters such as level, etc, above
  8038.                         if ( $types_to_go[$max_index_to_go] eq 'b' ) {
  8039.                             unstore_token_to_go();
  8040.                         }
  8041.                         store_token_to_go();
  8042.  
  8043.                         note_added_semicolon();
  8044.                         restore_current_token();
  8045.                     }
  8046.  
  8047.                     # then write out everything before this closing curly brace
  8048.                     output_line_to_go();
  8049.  
  8050.                 }
  8051.  
  8052.                 # Now update for side comment
  8053.                 if ($side_comment_follows) { $no_internal_newlines = 1 }
  8054.  
  8055.                 # store the closing curly brace
  8056.                 store_token_to_go();
  8057.  
  8058.                 # ok, we just stored a closing curly brace.  Often, but
  8059.                 # not always, we want to end the line immediately.
  8060.                 # So now we have to check for special cases.
  8061.  
  8062.                 # if this '}' successfully ends a one-line block..
  8063.                 my $is_one_line_block = 0;
  8064.                 if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
  8065.  
  8066.                     $is_one_line_block = 1;
  8067.  
  8068.                     # we have to actually make it by removing tentative
  8069.                     # breaks that were set within it
  8070.                     undo_forced_breakpoint_stack(0);
  8071.                     set_nobreaks( $index_start_one_line_block,
  8072.                         $max_index_to_go - 1 );
  8073.  
  8074.                     # then re-initialize for the next one-line block
  8075.                     destroy_one_line_block();
  8076.  
  8077.                     # then decide if we want to break after the '}' ..
  8078.                     # We will keep going to allow certain brace followers as in:
  8079.                     #   do { $ifclosed = 1; last } unless $losing;
  8080.                     #
  8081.                     # But make a line break if the curly ends a
  8082.                     # significant block:
  8083.                     #    /^(until|while|for|if|elsif|else)$/
  8084.                     if ( $is_until_while_for_if_elsif_else{$block_type} ) {
  8085.                         output_line_to_go() unless ($no_internal_newlines);
  8086.                     }
  8087.                 }
  8088.  
  8089.                 # set string indicating what we need to look for brace follower
  8090.                 # tokens
  8091.                 if ( $block_type eq 'do' ) {
  8092.                     $rbrace_follower = \%is_do_follower;
  8093.                 }
  8094.                 elsif ( $block_type =~ /^(if|elsif|unless)$/ ) {
  8095.                     $rbrace_follower = \%is_if_brace_follower;
  8096.                 }
  8097.                 elsif ( $block_type eq 'else' ) {
  8098.                     $rbrace_follower = \%is_else_brace_follower;
  8099.                 }
  8100.  
  8101.                 # added eval for borris.t
  8102.                 # /^(sort|map|grep|eval)$/
  8103.                 elsif ( $is_sort_map_grep_eval{$block_type} ) {
  8104.                     $rbrace_follower = undef;
  8105.                 }
  8106.  
  8107.                 # anonymous sub
  8108.                 elsif ( $block_type =~ /^sub\W*$/ ) {
  8109.  
  8110.                     if ($is_one_line_block) {
  8111.                         $rbrace_follower = \%is_anon_sub_1_brace_follower;
  8112.                     }
  8113.                     else {
  8114.                         $rbrace_follower = \%is_anon_sub_brace_follower;
  8115.                     }
  8116.                 }
  8117.  
  8118.                 # TESTING ONLY for SWITCH/CASE - this is where to start
  8119.                 # recoding to retain else's on the same line as a case,
  8120.                 # but there is a lot more that would need to be done.
  8121.                 ##elsif ($block_type eq 'case') {$rbrace_follower = {else=>1};}
  8122.  
  8123.                 # None of the above: specify what can follow a closing
  8124.                 # brace of a block which is not an
  8125.                 # if/elsif/else/do/sort/map/grep/eval
  8126.                 # Testfiles:
  8127.                 # 'Toolbar.pm', 'Menubar.pm', bless.t, '3rules.pl', 'break1.t
  8128.                 else {
  8129.                     $rbrace_follower = \%is_other_brace_follower;
  8130.                 }
  8131.  
  8132.                 # See if an elsif block is followed by another elsif or else;
  8133.                 # complain if not.
  8134.                 if ( $block_type eq 'elsif' ) {
  8135.  
  8136.                     if ( $next_nonblank_token_type eq 'b' ) {    # end of line?
  8137.                         $looking_for_else = 1;    # ok, check on next line
  8138.                     }
  8139.                     else {
  8140.  
  8141.                         unless ( $next_nonblank_token =~ /^(elsif|else)$/ ) {
  8142.                             write_logfile_entry("No else block :(\n");
  8143.                         }
  8144.                     }
  8145.                 }
  8146.  
  8147.                 # keep going after these block types: map,sort,grep
  8148.                 # added eval for borris.t
  8149.                 #     /^(sort|grep|map|eval)$/
  8150.                 if ( $is_sort_map_grep_eval{$block_type} ) {
  8151.  
  8152.                     # keep going
  8153.                 }
  8154.  
  8155.                 # if no more tokens, postpone decision until re-entring
  8156.                 elsif ( ( $next_nonblank_token_type eq 'b' )
  8157.                     && $rOpts_add_newlines )
  8158.                 {
  8159.                     unless ($rbrace_follower) {
  8160.                         output_line_to_go() unless ($no_internal_newlines);
  8161.                     }
  8162.                 }
  8163.  
  8164.                 elsif ($rbrace_follower) {
  8165.  
  8166.                     unless ( $rbrace_follower->{$next_nonblank_token} ) {
  8167.                         output_line_to_go() unless ($no_internal_newlines);
  8168.                     }
  8169.                     $rbrace_follower = undef;
  8170.                 }
  8171.  
  8172.                 else {
  8173.                     output_line_to_go() unless ($no_internal_newlines);
  8174.                 }
  8175.  
  8176.             }    # end treatment of closing block token
  8177.  
  8178.             # handle semicolon
  8179.             elsif ( $type eq ';' ) {
  8180.  
  8181.                 # kill one-line blocks with too many semicolons
  8182.                 $semicolons_before_block_self_destruct--;
  8183.                 if (
  8184.                     ( $semicolons_before_block_self_destruct < 0 )
  8185.                     || (   $semicolons_before_block_self_destruct == 0
  8186.                         && $next_nonblank_token_type !~ /^[b\}]$/ )
  8187.                   )
  8188.                 {
  8189.                     destroy_one_line_block();
  8190.                 }
  8191.  
  8192.                 # Remove unnecessary semicolons, but not after bare
  8193.                 # blocks, where it could be unsafe if the brace is
  8194.                 # mistokenized.
  8195.                 if (
  8196.                     (
  8197.                         $last_nonblank_token eq '}'
  8198.                         && (
  8199.                             $is_block_without_semicolon{
  8200.                                 $last_nonblank_block_type}
  8201.                             || $last_nonblank_block_type =~ /^sub\s+\w/
  8202.                             || $last_nonblank_block_type =~ /^\w+:$/ )
  8203.                     )
  8204.                     || $last_nonblank_type eq ';'
  8205.                   )
  8206.                 {
  8207.  
  8208.                     if (
  8209.                         $rOpts->{'delete-semicolons'}
  8210.  
  8211.                         # don't delete ; before a # because it would promote it
  8212.                         # to a block comment
  8213.                         && ( $next_nonblank_token_type ne '#' )
  8214.                       )
  8215.                     {
  8216.                         note_deleted_semicolon();
  8217.                         output_line_to_go()
  8218.                           unless ( $no_internal_newlines
  8219.                             || $index_start_one_line_block != UNDEFINED_INDEX );
  8220.                         next;
  8221.                     }
  8222.                     else {
  8223.                         write_logfile_entry("Extra ';'\n");
  8224.                     }
  8225.                 }
  8226.                 store_token_to_go();
  8227.  
  8228.                 output_line_to_go()
  8229.                   unless ( $no_internal_newlines
  8230.                     || ( $next_nonblank_token eq '}' ) );
  8231.  
  8232.             }
  8233.  
  8234.             # handle here_doc target string
  8235.             elsif ( $type eq 'h' ) {
  8236.                 $no_internal_newlines =
  8237.                   1;    # no newlines after seeing here-target
  8238.                 destroy_one_line_block();
  8239.                 store_token_to_go();
  8240.             }
  8241.  
  8242.             # handle all other token types
  8243.             else {
  8244.  
  8245.                 # if this is a blank...
  8246.                 if ( $type eq 'b' ) {
  8247.  
  8248.                     # make it just one character
  8249.                     $token = ' ' if $rOpts_add_whitespace;
  8250.  
  8251.                     # delete it if unwanted by whitespace rules
  8252.                     # or we are deleting all whitespace
  8253.                     my $ws = $$rwhite_space_flag[ $j + 1 ];
  8254.                     if ( ( defined($ws) && $ws == -1 )
  8255.                         || $rOpts_delete_old_whitespace )
  8256.                     {
  8257.  
  8258.                         # unless it might make a syntax error
  8259.                         next
  8260.                           unless is_essential_whitespace(
  8261.                             $last_last_nonblank_token,
  8262.                             $last_last_nonblank_type,
  8263.                             $tokens_to_go[$max_index_to_go],
  8264.                             $types_to_go[$max_index_to_go],
  8265.                             $$rtokens[ $j + 1 ],
  8266.                             $$rtoken_type[ $j + 1 ]
  8267.                           );
  8268.                     }
  8269.                 }
  8270.                 store_token_to_go();
  8271.             }
  8272.  
  8273.             # remember two previous nonblank OUTPUT tokens
  8274.             if ( $type ne '#' && $type ne 'b' ) {
  8275.                 $last_last_nonblank_token = $last_nonblank_token;
  8276.                 $last_last_nonblank_type  = $last_nonblank_type;
  8277.                 $last_nonblank_token      = $token;
  8278.                 $last_nonblank_type       = $type;
  8279.                 $last_nonblank_block_type = $block_type;
  8280.             }
  8281.  
  8282.             # unset the continued-quote flag since it only applies to the
  8283.             # first token, and we want to resume normal formatting if
  8284.             # there are additional tokens on the line
  8285.             $in_continued_quote = 0;
  8286.  
  8287.         }    # end of loop over all tokens in this 'line_of_tokens'
  8288.  
  8289.         # we have to flush ..
  8290.         if (
  8291.  
  8292.             # if there is a side comment
  8293.             ( ( $type eq '#' ) && !$rOpts->{'delete-side-comments'} )
  8294.  
  8295.             # if this line which ends in a quote
  8296.             || $in_quote
  8297.  
  8298.             # if this is a VERSION statement
  8299.             || $is_VERSION_statement
  8300.  
  8301.             # to keep a label on one line if that is how it is now
  8302.             || ( ( $type eq 'J' ) && ( $max_index_to_go == 0 ) )
  8303.  
  8304.             # if we are instructed to keep all old line breaks
  8305.             || !$rOpts->{'delete-old-newlines'}
  8306.           )
  8307.         {
  8308.             destroy_one_line_block();
  8309.             output_line_to_go();
  8310.         }
  8311.  
  8312.         # mark old line breakpoints in current output stream
  8313.         if ( $max_index_to_go >= 0 && !$rOpts_ignore_old_line_breaks ) {
  8314.             $old_breakpoint_to_go[$max_index_to_go] = 1;
  8315.         }
  8316.     }
  8317. }    # end print_line_of_tokens
  8318.  
  8319. sub note_added_semicolon {
  8320.     $last_added_semicolon_at = $input_line_number;
  8321.     if ( $added_semicolon_count == 0 ) {
  8322.         $first_added_semicolon_at = $last_added_semicolon_at;
  8323.     }
  8324.     $added_semicolon_count++;
  8325.     write_logfile_entry("Added ';' here\n");
  8326. }
  8327.  
  8328. sub note_deleted_semicolon {
  8329.     $last_deleted_semicolon_at = $input_line_number;
  8330.     if ( $deleted_semicolon_count == 0 ) {
  8331.         $first_deleted_semicolon_at = $last_deleted_semicolon_at;
  8332.     }
  8333.     $deleted_semicolon_count++;
  8334.     write_logfile_entry("Deleted unnecessary ';'\n");    # i hope ;)
  8335. }
  8336.  
  8337. sub note_embedded_tab {
  8338.     $embedded_tab_count++;
  8339.     $last_embedded_tab_at = $input_line_number;
  8340.     if ( !$first_embedded_tab_at ) {
  8341.         $first_embedded_tab_at = $last_embedded_tab_at;
  8342.     }
  8343.  
  8344.     if ( $embedded_tab_count <= MAX_NAG_MESSAGES ) {
  8345.         write_logfile_entry("Embedded tabs in quote or pattern\n");
  8346.     }
  8347. }
  8348.  
  8349. sub starting_one_line_block {
  8350.  
  8351.     # after seeing an opening curly brace, look for the closing brace
  8352.     # and see if the entire block will fit on a line.  This routine is
  8353.     # not always right because it uses the old whitespace, so a check
  8354.     # is made later (at the closing brace) to make sure we really
  8355.     # have a one-line block.  We have to do this preliminary check,
  8356.     # though, because otherwise we would always break at a semicolon
  8357.     # within a one-line block if the block contains multiple statements.
  8358.  
  8359.     my ( $j, $jmax, $level, $slevel, $ci_level, $rtokens, $rtoken_type,
  8360.         $rblock_type )
  8361.       = @_;
  8362.  
  8363.     # kill any current block - we can only go 1 deep
  8364.     destroy_one_line_block();
  8365.  
  8366.     # return value:
  8367.     #  1=distance from start of block to opening brace exceeds line length
  8368.     #  0=otherwise
  8369.  
  8370.     my $i_start = 0;
  8371.  
  8372.     # shouldn't happen: there must have been a prior call to
  8373.     # store_token_to_go to put the opening brace in the output stream
  8374.     if ( $max_index_to_go < 0 ) {
  8375.         warning("program bug: store_token_to_go called incorrectly\n");
  8376.         report_definite_bug();
  8377.     }
  8378.     else {
  8379.  
  8380.         # cannot use one-line blocks with cuddled else else/elsif lines
  8381.         if ( ( $tokens_to_go[0] eq '}' ) && $rOpts_cuddled_else ) {
  8382.             return 0;
  8383.         }
  8384.     }
  8385.  
  8386.     my $block_type = $$rblock_type[$j];
  8387.  
  8388.     # find the starting keyword for this block (such as 'if', 'else', ...)
  8389.  
  8390.     if ( $block_type =~ /^[\{\}\;\:]$/ ) {
  8391.         $i_start = $max_index_to_go;
  8392.     }
  8393.  
  8394.     elsif ( $last_last_nonblank_token_to_go eq ')' ) {
  8395.  
  8396.         # For something like "if (xxx) {", the keyword "if" will be
  8397.         # just after the most recent break. This will be 0 unless
  8398.         # we have just killed a one-line block and are starting another.
  8399.         # (doif.t)
  8400.         $i_start = $index_max_forced_break + 1;
  8401.         if ( $types_to_go[$i_start] eq 'b' ) {
  8402.             $i_start++;
  8403.         }
  8404.  
  8405.         unless ( $tokens_to_go[$i_start] eq $block_type ) {
  8406.             return 0;
  8407.         }
  8408.     }
  8409.  
  8410.     # the previous nonblank token should start these block types
  8411.     elsif (
  8412.         ( $last_last_nonblank_token_to_go eq $block_type )
  8413.         || (   $block_type =~ /^sub/
  8414.             && $last_last_nonblank_token_to_go =~ /^sub/ )
  8415.       )
  8416.     {
  8417.         $i_start = $last_last_nonblank_index_to_go;
  8418.     }
  8419.  
  8420.     # patch for SWITCH/CASE to retain one-line case/when blocks
  8421.     elsif ( $block_type eq 'case' || $block_type eq 'when' ) {
  8422.         $i_start = $index_max_forced_break + 1;
  8423.         if ( $types_to_go[$i_start] eq 'b' ) {
  8424.             $i_start++;
  8425.         }
  8426.         unless ( $tokens_to_go[$i_start] eq $block_type ) {
  8427.             return 0;
  8428.         }
  8429.     }
  8430.  
  8431.     else {
  8432.         return 1;
  8433.     }
  8434.  
  8435.     my $pos = total_line_length( $i_start, $max_index_to_go ) - 1;
  8436.  
  8437.     my $i;
  8438.  
  8439.     # see if length is too long to even start
  8440.     if ( $pos > $rOpts_maximum_line_length ) {
  8441.         return 1;
  8442.     }
  8443.  
  8444.     for ( $i = $j + 1 ; $i <= $jmax ; $i++ ) {
  8445.  
  8446.         # old whitespace could be arbitrarily large, so don't use it
  8447.         if ( $$rtoken_type[$i] eq 'b' ) { $pos += 1 }
  8448.         else { $pos += length( $$rtokens[$i] ) }
  8449.  
  8450.         # Return false result if we exceed the maximum line length,
  8451.         if ( $pos > $rOpts_maximum_line_length ) {
  8452.             return 0;
  8453.         }
  8454.  
  8455.         # or encounter another opening brace before finding the closing brace.
  8456.         elsif ($$rtokens[$i] eq '{'
  8457.             && $$rtoken_type[$i] eq '{'
  8458.             && $$rblock_type[$i] )
  8459.         {
  8460.             return 0;
  8461.         }
  8462.  
  8463.         # if we find our closing brace..
  8464.         elsif ($$rtokens[$i] eq '}'
  8465.             && $$rtoken_type[$i] eq '}'
  8466.             && $$rblock_type[$i] )
  8467.         {
  8468.  
  8469.             # be sure any trailing comment also fits on the line
  8470.             my $i_nonblank =
  8471.               ( $$rtoken_type[ $i + 1 ] eq 'b' ) ? $i + 2 : $i + 1;
  8472.  
  8473.             if ( $$rtoken_type[$i_nonblank] eq '#' ) {
  8474.                 $pos += length( $$rtokens[$i_nonblank] );
  8475.  
  8476.                 if ( $i_nonblank > $i + 1 ) {
  8477.                     $pos += length( $$rtokens[ $i + 1 ] );
  8478.                 }
  8479.  
  8480.                 if ( $pos > $rOpts_maximum_line_length ) {
  8481.                     return 0;
  8482.                 }
  8483.             }
  8484.  
  8485.             # ok, it's a one-line block
  8486.             create_one_line_block( $i_start, 20 );
  8487.             return 0;
  8488.         }
  8489.  
  8490.         # just keep going for other characters
  8491.         else {
  8492.         }
  8493.     }
  8494.  
  8495.     # Allow certain types of new one-line blocks to form by joining
  8496.     # input lines.  These can be safely done, but for other block types,
  8497.     # we keep old one-line blocks but do not form new ones. It is not
  8498.     # always a good idea to make as many one-line blocks as possible,
  8499.     # so other types are not done.  The user can always use -mangle.
  8500.     #     /^(eval|map|grep|sort)$/
  8501.     if ( $is_sort_map_grep_eval{$block_type} ) {
  8502.         create_one_line_block( $i_start, 1 );
  8503.     }
  8504.  
  8505.     return 0;
  8506. }
  8507.  
  8508. sub unstore_token_to_go {
  8509.  
  8510.     # remove most recent token from output stream
  8511.     if ( $max_index_to_go > 0 ) {
  8512.         $max_index_to_go--;
  8513.     }
  8514.     else {
  8515.         $max_index_to_go = UNDEFINED_INDEX;
  8516.     }
  8517.  
  8518. }
  8519.  
  8520. sub want_blank_line {
  8521.     flush();
  8522.     $file_writer_object->want_blank_line();
  8523. }
  8524.  
  8525. sub write_unindented_line {
  8526.     flush();
  8527.     $file_writer_object->write_line( $_[0] );
  8528. }
  8529.  
  8530. sub undo_lp_ci {
  8531.  
  8532.     # If there is a single, long parameter within parens, like this:
  8533.     #
  8534.     #  $self->command( "/msg "
  8535.     #        . $infoline->chan
  8536.     #        . " You said $1, but did you know that it's square was "
  8537.     #        . $1 * $1 . " ?" );
  8538.     #
  8539.     # we can remove the continuation indentation of the 2nd and higher lines
  8540.     # to achieve this effect, which is more pleasing:
  8541.     #
  8542.     #  $self->command("/msg "
  8543.     #                 . $infoline->chan
  8544.     #                 . " You said $1, but did you know that it's square was "
  8545.     #                 . $1 * $1 . " ?");
  8546.  
  8547.     my ( $line_open, $i_start, $closing_index, $ri_first, $ri_last ) = @_;
  8548.     my $max_line = @$ri_first - 1;
  8549.  
  8550.     # must be multiple lines
  8551.     return unless $max_line > $line_open;
  8552.  
  8553.     my $lev_start     = $levels_to_go[$i_start];
  8554.     my $ci_start_plus = 1 + $ci_levels_to_go[$i_start];
  8555.  
  8556.     # see if all additional lines in this container have continuation
  8557.     # indentation
  8558.     my $n;
  8559.     my $line_1 = 1 + $line_open;
  8560.     for ( $n = $line_1 ; $n <= $max_line ; ++$n ) {
  8561.         my $ibeg = $$ri_first[$n];
  8562.         my $iend = $$ri_last[$n];
  8563.         if ( $ibeg eq $closing_index ) { $n--; last }
  8564.         return if ( $lev_start != $levels_to_go[$ibeg] );
  8565.         return if ( $ci_start_plus != $ci_levels_to_go[$ibeg] );
  8566.         last   if ( $closing_index <= $iend );
  8567.     }
  8568.  
  8569.     # we can reduce the indentation of all continuation lines
  8570.     my $continuation_line_count = $n - $line_open;
  8571.     @ci_levels_to_go[ @$ri_first[ $line_1 .. $n ] ] =
  8572.       (0) x ($continuation_line_count);
  8573.     @leading_spaces_to_go[ @$ri_first[ $line_1 .. $n ] ] =
  8574.       @reduced_spaces_to_go[ @$ri_first[ $line_1 .. $n ] ];
  8575. }
  8576.  
  8577. sub set_logical_padding {
  8578.  
  8579.     # Look at a batch of lines and see if extra padding can improve the
  8580.     # alignment when there are leading logical operators. Here is an
  8581.     # example, in which some extra space is introduced before
  8582.     # '( $year' to make it line up with the subsequent lines:
  8583.     #
  8584.     #       if (   ( $Year < 1601 )
  8585.     #           || ( $Year > 2899 )
  8586.     #           || ( $EndYear < 1601 )
  8587.     #           || ( $EndYear > 2899 ) )
  8588.     #       {
  8589.     #           &Error_OutOfRange;
  8590.     #       }
  8591.     #
  8592.     my ( $ri_first, $ri_last ) = @_;
  8593.     my $max_line = @$ri_first - 1;
  8594.  
  8595.     my ( $ibeg, $ibeg_next, $ibegm, $iend, $iendm, $ipad, $line, $pad_spaces,
  8596.         $tok_next, $has_leading_op_next, $has_leading_op );
  8597.  
  8598.     # looking at each line of this batch..
  8599.     foreach $line ( 0 .. $max_line - 1 ) {
  8600.  
  8601.         # see if the next line begins with a logical operator
  8602.         $ibeg                = $$ri_first[$line];
  8603.         $iend                = $$ri_last[$line];
  8604.         $ibeg_next           = $$ri_first[ $line + 1 ];
  8605.         $tok_next            = $tokens_to_go[$ibeg_next];
  8606.         $has_leading_op_next = ( $tok_next =~ /^(\&\&|\|\||and|or)$/ );
  8607.         next unless ($has_leading_op_next);
  8608.  
  8609.         # next line must not be at lesser depth
  8610.         next
  8611.           if ( $nesting_depth_to_go[$ibeg] > $nesting_depth_to_go[$ibeg_next] );
  8612.  
  8613.         # identify the token in this line to be padded on the left
  8614.         $ipad = undef;
  8615.  
  8616.         # handle lines at same depth...
  8617.         if ( $nesting_depth_to_go[$ibeg] == $nesting_depth_to_go[$ibeg_next] ) {
  8618.  
  8619.             # previous line must be at lesser depth if this is not first line
  8620.             # of the batch
  8621.             if ( $line > 0 ) {
  8622.                 next
  8623.                   if $nesting_depth_to_go[$ibegm] >=
  8624.                   $nesting_depth_to_go[$ibeg];
  8625.  
  8626.                 # skip if we are at same depth as a previous line
  8627.                 # with leading logical operator
  8628.                 next if $has_leading_op;
  8629.                 $ipad = $ibeg;
  8630.             }
  8631.  
  8632.             # for first line of the batch..
  8633.             else {
  8634.  
  8635.                 # if this is text after closing '}'
  8636.                 # then look for an interior token to pad
  8637.                 if ( $types_to_go[$ibeg] eq '}' ) {
  8638.  
  8639.                 }
  8640.  
  8641.                 # otherwise, we might pad if it looks really good
  8642.                 else {
  8643.  
  8644.                     # we might pad token $ibeg, so be sure that it
  8645.                     # is at the same depth as the next line.
  8646.                     next
  8647.                       if ( $nesting_depth_to_go[ $ibeg + 1 ] !=
  8648.                         $nesting_depth_to_go[$ibeg_next] );
  8649.  
  8650.                     # We can pad on line 1 of a statement if at least 3
  8651.                     # lines will be aligned. Otherwise, it
  8652.                     # can look very confusing.
  8653.                     if ( $max_line > 2 ) {
  8654.                         my $leading_token = $tokens_to_go[$ibeg_next];
  8655.                         my $count         = 1;
  8656.                         foreach my $l ( 2 .. 3 ) {
  8657.                             my $ibeg_next_next = $$ri_first[ $line + $l ];
  8658.                             next
  8659.                               unless $tokens_to_go[$ibeg_next_next] eq
  8660.                               $leading_token;
  8661.                             $count++;
  8662.                         }
  8663.                         next unless $count == 3;
  8664.                         $ipad = $ibeg;
  8665.                     }
  8666.                     else {
  8667.                         next;
  8668.                     }
  8669.                 }
  8670.             }
  8671.         }
  8672.  
  8673.         # find interior token to pad if necessary
  8674.         if ( !defined($ipad) ) {
  8675.  
  8676.             for ( my $i = $ibeg ; ( $i < $iend ) && !$ipad ; $i++ ) {
  8677.  
  8678.                 # find any unclosed container
  8679.                 next
  8680.                   unless ( $type_sequence_to_go[$i]
  8681.                     && $mate_index_to_go[$i] > $iend );
  8682.  
  8683.                 # find next nonblank token to pad
  8684.                 $ipad = $i + 1;
  8685.                 if ( $types_to_go[$ipad] eq 'b' ) {
  8686.                     $ipad++;
  8687.                     last if ( $ipad > $iend );
  8688.                 }
  8689.             }
  8690.             last unless $ipad;
  8691.         }
  8692.  
  8693.         # lines must be somewhat similar to be padded..
  8694.         my $iend_next  = $$ri_last[ $line + 1 ];
  8695.         my $inext_next = $ibeg_next + 1;
  8696.         if ( $types_to_go[$inext_next] eq 'b' ) {
  8697.             $inext_next++;
  8698.         }
  8699.         my $type = $types_to_go[$ipad];
  8700.  
  8701.         # see if there are multiple continuation lines
  8702.         my $logical_continuation_lines = 1;
  8703.         if ( $line + 2 <= $max_line ) {
  8704.             my $leading_token  = $tokens_to_go[$ibeg_next];
  8705.             my $ibeg_next_next = $$ri_first[ $line + 2 ];
  8706.             if (   $tokens_to_go[$ibeg_next_next] eq $leading_token
  8707.                 && $nesting_depth_to_go[$ibeg_next] eq
  8708.                 $nesting_depth_to_go[$ibeg_next_next] )
  8709.             {
  8710.                 $logical_continuation_lines++;
  8711.             }
  8712.         }
  8713.         if (
  8714.  
  8715.             # next line must not be at greater depth
  8716.             $nesting_depth_to_go[ $iend_next + 1 ] <=
  8717.             $nesting_depth_to_go[$ipad]
  8718.  
  8719.             # and ..
  8720.             && (
  8721.  
  8722.                 # either we have multiple continuation lines to follow
  8723.                 # and we are not padding the first token
  8724.                 ( $logical_continuation_lines > 1 && $ipad > 0 )
  8725.  
  8726.                 # or..
  8727.                 || (
  8728.  
  8729.                     # types must match
  8730.                     $types_to_go[$inext_next] eq $type
  8731.  
  8732.                     # and keywords must match if keyword
  8733.                     && !(
  8734.                            $type eq 'k'
  8735.                         && $tokens_to_go[$ipad] ne $tokens_to_go[$inext_next]
  8736.                     )
  8737.                 )
  8738.             )
  8739.           )
  8740.         {
  8741.             my $length_1 = total_line_length( $ibeg,      $ipad - 1 );
  8742.             my $length_2 = total_line_length( $ibeg_next, $inext_next - 1 );
  8743.             $pad_spaces = $length_2 - $length_1;
  8744.  
  8745.             # make sure this won't change if -lp is used
  8746.             my $indentation_1 = $leading_spaces_to_go[$ibeg];
  8747.             if ( ref($indentation_1) ) {
  8748.                 if ( $indentation_1->get_RECOVERABLE_SPACES() == 0 ) {
  8749.                     my $indentation_2 = $leading_spaces_to_go[$ibeg_next];
  8750.                     unless ( $indentation_2->get_RECOVERABLE_SPACES() == 0 ) {
  8751.                         $pad_spaces = 0;
  8752.                     }
  8753.                 }
  8754.             }
  8755.  
  8756.             # we might be able to handle a pad of -1 by removing a blank
  8757.             # token
  8758.             if ( $pad_spaces < 0 ) {
  8759.                 if ( $pad_spaces == -1 ) {
  8760.                     if ( $ipad > $ibeg && $types_to_go[ $ipad - 1 ] eq 'b' ) {
  8761.                         $tokens_to_go[ $ipad - 1 ] = '';
  8762.                     }
  8763.                 }
  8764.                 $pad_spaces = 0;
  8765.             }
  8766.  
  8767.             # now apply any padding for alignment
  8768.             if ( $ipad >= 0 && $pad_spaces ) {
  8769.                 my $length_t = total_line_length( $ibeg, $iend );
  8770.                 if ( $pad_spaces + $length_t <= $rOpts_maximum_line_length ) {
  8771.                     $tokens_to_go[$ipad] =
  8772.                       ' ' x $pad_spaces . $tokens_to_go[$ipad];
  8773.                 }
  8774.             }
  8775.         }
  8776.     }
  8777.     continue {
  8778.         $iendm          = $iend;
  8779.         $ibegm          = $ibeg;
  8780.         $has_leading_op = $has_leading_op_next;
  8781.     }    # end of loop over lines
  8782.     return;
  8783. }
  8784.  
  8785. sub correct_lp_indentation {
  8786.  
  8787.     # When the -lp option is used, we need to make a last pass through
  8788.     # each line to correct the indentation positions in case they differ
  8789.     # from the predictions.  This is necessary because perltidy uses a
  8790.     # predictor/corrector method for aligning with opening parens.  The
  8791.     # predictor is usually good, but sometimes stumbles.  The corrector
  8792.     # tries to patch things up once the actual opening paren locations
  8793.     # are known.
  8794.     my ( $ri_first, $ri_last ) = @_;
  8795.     my $do_not_pad = 0;
  8796.  
  8797.     #  Note on flag '$do_not_pad':
  8798.     #  We want to avoid a situation like this, where the aligner inserts
  8799.     #  whitespace before the '=' to align it with a previous '=', because
  8800.     #  otherwise the parens might become mis-aligned in a situation like
  8801.     #  this, where the '=' has become aligned with the previous line,
  8802.     #  pushing the opening '(' forward beyond where we want it.
  8803.     #
  8804.     #  $mkFloor::currentRoom = '';
  8805.     #  $mkFloor::c_entry     = $c->Entry(
  8806.     #                                 -width        => '10',
  8807.     #                                 -relief       => 'sunken',
  8808.     #                                 ...
  8809.     #                                 );
  8810.     #
  8811.     #  We leave it to the aligner to decide how to do this.
  8812.  
  8813.     # first remove continuation indentation if appropriate
  8814.     my $max_line = @$ri_first - 1;
  8815.  
  8816.     # looking at each line of this batch..
  8817.     my ( $ibeg, $iend );
  8818.     my $line;
  8819.     foreach $line ( 0 .. $max_line ) {
  8820.         $ibeg = $$ri_first[$line];
  8821.         $iend = $$ri_last[$line];
  8822.  
  8823.         # looking at each token in this output line..
  8824.         my $i;
  8825.         foreach $i ( $ibeg .. $iend ) {
  8826.  
  8827.             # How many space characters to place before this token
  8828.             # for special alignment.  Actual padding is done in the
  8829.             # continue block.
  8830.  
  8831.             # looking for next unvisited indentation item
  8832.             my $indentation = $leading_spaces_to_go[$i];
  8833.             if ( !$indentation->get_MARKED() ) {
  8834.                 $indentation->set_MARKED(1);
  8835.  
  8836.                 # looking for indentation item for which we are aligning
  8837.                 # with parens, braces, and brackets
  8838.                 next unless ( $indentation->get_ALIGN_PAREN() );
  8839.  
  8840.                 # skip closed container on this line
  8841.                 if ( $i > $ibeg ) {
  8842.                     my $im = $i - 1;
  8843.                     if ( $types_to_go[$im] eq 'b' && $im > $ibeg ) { $im-- }
  8844.                     if (   $type_sequence_to_go[$im]
  8845.                         && $mate_index_to_go[$im] <= $iend )
  8846.                     {
  8847.                         next;
  8848.                     }
  8849.                 }
  8850.  
  8851.                 if ( $line == 1 && $i == $ibeg ) {
  8852.                     $do_not_pad = 1;
  8853.                 }
  8854.  
  8855.                 # Ok, let's see what the error is and try to fix it
  8856.                 my $actual_pos;
  8857.                 my $predicted_pos = $indentation->get_SPACES();
  8858.                 if ( $i > $ibeg ) {
  8859.  
  8860.                     # token is mid-line - use length to previous token
  8861.                     $actual_pos = total_line_length( $ibeg, $i - 1 );
  8862.  
  8863.                     # for mid-line token, we must check to see if all
  8864.                     # additional lines have continuation indentation,
  8865.                     # and remove it if so.  Otherwise, we do not get
  8866.                     # good alignment.
  8867.                     my $closing_index = $indentation->get_CLOSED();
  8868.                     if ( $closing_index > $iend ) {
  8869.                         my $ibeg_next = $$ri_first[ $line + 1 ];
  8870.                         if ( $ci_levels_to_go[$ibeg_next] > 0 ) {
  8871.                             undo_lp_ci( $line, $i, $closing_index, $ri_first,
  8872.                                 $ri_last );
  8873.                         }
  8874.                     }
  8875.                 }
  8876.                 elsif ( $line > 0 ) {
  8877.  
  8878.                     # handle case where token starts a new line;
  8879.                     # use length of previous line
  8880.                     my $ibegm = $$ri_first[ $line - 1 ];
  8881.                     my $iendm = $$ri_last[ $line - 1 ];
  8882.                     $actual_pos = total_line_length( $ibegm, $iendm );
  8883.  
  8884.                     # follow -pt style
  8885.                     ++$actual_pos
  8886.                       if ( $types_to_go[ $iendm + 1 ] eq 'b' );
  8887.                 }
  8888.                 else {
  8889.  
  8890.                     # token is first character of first line of batch
  8891.                     $actual_pos = $predicted_pos;
  8892.                 }
  8893.  
  8894.                 my $move_right = $actual_pos - $predicted_pos;
  8895.  
  8896.                 # done if no error to correct (gnu2.t)
  8897.                 if ( $move_right == 0 ) {
  8898.                     $indentation->set_RECOVERABLE_SPACES($move_right);
  8899.                     next;
  8900.                 }
  8901.  
  8902.                 # if we have not seen closure for this indentation in
  8903.                 # this batch, we can only pass on a request to the
  8904.                 # vertical aligner
  8905.                 my $closing_index = $indentation->get_CLOSED();
  8906.  
  8907.                 if ( $closing_index < 0 ) {
  8908.                     $indentation->set_RECOVERABLE_SPACES($move_right);
  8909.                     next;
  8910.                 }
  8911.  
  8912.                 # If necessary, look ahead to see if there is really any
  8913.                 # leading whitespace dependent on this whitespace, and
  8914.                 # also find the longest line using this whitespace.
  8915.                 # Since it is always safe to move left if there are no
  8916.                 # dependents, we only need to do this if we may have
  8917.                 # dependent nodes or need to move right.
  8918.  
  8919.                 my $right_margin = 0;
  8920.                 my $have_child   = $indentation->get_HAVE_CHILD();
  8921.  
  8922.                 my %saw_indentation;
  8923.                 my $line_count = 1;
  8924.                 $saw_indentation{$indentation} = $indentation;
  8925.  
  8926.                 if ( $have_child || $move_right > 0 ) {
  8927.                     $have_child = 0;
  8928.                     my $max_length = 0;
  8929.                     if ( $i == $ibeg ) {
  8930.                         $max_length = total_line_length( $ibeg, $iend );
  8931.                     }
  8932.  
  8933.                     # look ahead at the rest of the lines of this batch..
  8934.                     my $line_t;
  8935.                     foreach $line_t ( $line + 1 .. $max_line ) {
  8936.                         my $ibeg_t = $$ri_first[$line_t];
  8937.                         my $iend_t = $$ri_last[$line_t];
  8938.                         last if ( $closing_index <= $ibeg_t );
  8939.  
  8940.                         # remember all different indentation objects
  8941.                         my $indentation_t = $leading_spaces_to_go[$ibeg_t];
  8942.                         $saw_indentation{$indentation_t} = $indentation_t;
  8943.                         $line_count++;
  8944.  
  8945.                         # remember longest line in the group
  8946.                         my $length_t = total_line_length( $ibeg_t, $iend_t );
  8947.                         if ( $length_t > $max_length ) {
  8948.                             $max_length = $length_t;
  8949.                         }
  8950.                     }
  8951.                     $right_margin = $rOpts_maximum_line_length - $max_length;
  8952.                     if ( $right_margin < 0 ) { $right_margin = 0 }
  8953.                 }
  8954.  
  8955.                 my $first_line_comma_count =
  8956.                   grep { $_ eq ',' } @types_to_go[ $ibeg .. $iend ];
  8957.                 my $comma_count = $indentation->get_COMMA_COUNT();
  8958.                 my $arrow_count = $indentation->get_ARROW_COUNT();
  8959.  
  8960.                 # This is a simple approximate test for vertical alignment:
  8961.                 # if we broke just after an opening paren, brace, bracket,
  8962.                 # and there are 2 or more commas in the first line,
  8963.                 # and there are no '=>'s,
  8964.                 # then we are probably vertically aligned.  We could set
  8965.                 # an exact flag in sub scan_list, but this is good
  8966.                 # enough.
  8967.                 my $indentation_count     = keys %saw_indentation;
  8968.                 my $is_vertically_aligned =
  8969.                   (      $i == $ibeg
  8970.                       && $first_line_comma_count > 1
  8971.                       && $indentation_count == 1
  8972.                       && ( $arrow_count == 0 || $arrow_count == $line_count ) );
  8973.  
  8974.                 # Make the move if possible ..
  8975.                 if (
  8976.  
  8977.                     # we can always move left
  8978.                     $move_right < 0
  8979.  
  8980.                     # but we should only move right if we are sure it will
  8981.                     # not spoil vertical alignment
  8982.                     || ( $comma_count == 0 )
  8983.                     || ( $comma_count > 0 && !$is_vertically_aligned )
  8984.                   )
  8985.                 {
  8986.                     my $move =
  8987.                       ( $move_right <= $right_margin )
  8988.                       ? $move_right
  8989.                       : $right_margin;
  8990.  
  8991.                     foreach ( keys %saw_indentation ) {
  8992.                         $saw_indentation{$_}
  8993.                           ->permanently_decrease_AVAILABLE_SPACES( -$move );
  8994.                     }
  8995.                 }
  8996.  
  8997.                 # Otherwise, record what we want and the vertical aligner
  8998.                 # will try to recover it.
  8999.                 else {
  9000.                     $indentation->set_RECOVERABLE_SPACES($move_right);
  9001.                 }
  9002.             }
  9003.         }
  9004.     }
  9005.     return $do_not_pad;
  9006. }
  9007.  
  9008. # flush is called to output any tokens in the pipeline, so that
  9009. # an alternate source of lines can be written in the correct order
  9010.  
  9011. sub flush {
  9012.     destroy_one_line_block();
  9013.     output_line_to_go();
  9014.     Perl::Tidy::VerticalAligner::flush();
  9015. }
  9016.  
  9017. # output_line_to_go sends one logical line of tokens on down the
  9018. # pipeline to the VerticalAligner package, breaking the line into continuation
  9019. # lines as necessary.  The line of tokens is ready to go in the "to_go"
  9020. # arrays.
  9021.  
  9022. sub output_line_to_go {
  9023.  
  9024.     # debug stuff; this routine can be called from many points
  9025.     FORMATTER_DEBUG_FLAG_OUTPUT && do {
  9026.         my ( $a, $b, $c ) = caller;
  9027.         write_diagnostics(
  9028. "OUTPUT: output_line_to_go called: $a $c $last_nonblank_type $last_nonblank_token, one_line=$index_start_one_line_block, tokens to write=$max_index_to_go\n"
  9029.         );
  9030.         my $output_str = join "", @tokens_to_go[ 0 .. $max_index_to_go ];
  9031.         write_diagnostics("$output_str\n");
  9032.     };
  9033.  
  9034.     # just set a tentative breakpoint if we might be in a one-line block
  9035.     if ( $index_start_one_line_block != UNDEFINED_INDEX ) {
  9036.         set_forced_breakpoint($max_index_to_go);
  9037.         return;
  9038.     }
  9039.  
  9040.     my $cscw_block_comment;
  9041.     $cscw_block_comment = add_closing_side_comment()
  9042.       if ( $rOpts->{'closing-side-comments'} && $max_index_to_go >= 0 );
  9043.  
  9044.     match_opening_and_closing_tokens();
  9045.  
  9046.     # tell the -lp option we are outputting a batch so it can close
  9047.     # any unfinished items in its stack
  9048.     finish_lp_batch();
  9049.  
  9050.     my $imin = 0;
  9051.     my $imax = $max_index_to_go;
  9052.  
  9053.     # trim any blank tokens
  9054.     if ( $max_index_to_go >= 0 ) {
  9055.         if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
  9056.         if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
  9057.     }
  9058.  
  9059.     # anything left to write?
  9060.     if ( $imin <= $imax ) {
  9061.  
  9062.         # add a blank line before certain key types
  9063.         if ( $last_line_leading_type !~ /^[#b]/ ) {
  9064.             my $want_blank    = 0;
  9065.             my $leading_token = $tokens_to_go[$imin];
  9066.             my $leading_type  = $types_to_go[$imin];
  9067.  
  9068.             # blank lines before subs except declarations and one-liners
  9069.             # MCONVERSION LOCATION - for sub tokenization change
  9070.             if ( $leading_token =~ /^(sub\s)/ && $leading_type eq 'i' ) {
  9071.                 $want_blank = ( $rOpts->{'blanks-before-subs'} )
  9072.                   && (
  9073.                     terminal_type( \@types_to_go, \@block_type_to_go, $imin,
  9074.                         $imax ) !~ /^[\;\}]$/
  9075.                   );
  9076.             }
  9077.  
  9078.             # break before all package declarations
  9079.             # MCONVERSION LOCATION - for tokenizaton change
  9080.             elsif ( $leading_token =~ /^(package\s)/ && $leading_type eq 'i' ) {
  9081.                 $want_blank = ( $rOpts->{'blanks-before-subs'} );
  9082.             }
  9083.  
  9084.             # break before certain key blocks except one-liners
  9085.             if ( $leading_token =~ /^(BEGIN|END)$/ && $leading_type eq 'k' ) {
  9086.                 $want_blank = ( $rOpts->{'blanks-before-subs'} )
  9087.                   && (
  9088.                     terminal_type( \@types_to_go, \@block_type_to_go, $imin,
  9089.                         $imax ) ne '}'
  9090.                   );
  9091.             }
  9092.  
  9093.             # Break before certain block types if we haven't had a break at this
  9094.             # level for a while.  This is the difficult decision..
  9095.             elsif ($leading_token =~ /^(unless|if|while|until|for|foreach)$/
  9096.                 && $leading_type eq 'k' )
  9097.             {
  9098.                 my $lc = $nonblank_lines_at_depth[$last_line_leading_level];
  9099.                 if ( !defined($lc) ) { $lc = 0 }
  9100.  
  9101.                 $want_blank = $rOpts->{'blanks-before-blocks'}
  9102.                   && $lc >= $rOpts->{'long-block-line-count'}
  9103.                   && $file_writer_object->get_consecutive_nonblank_lines() >=
  9104.                   $rOpts->{'long-block-line-count'}
  9105.                   && (
  9106.                     terminal_type( \@types_to_go, \@block_type_to_go, $imin,
  9107.                         $imax ) ne '}'
  9108.                   );
  9109.             }
  9110.  
  9111.             if ($want_blank) {
  9112.  
  9113.                 # future: send blank line down normal path to VerticalAligner
  9114.                 Perl::Tidy::VerticalAligner::flush();
  9115.                 $file_writer_object->write_blank_code_line();
  9116.             }
  9117.         }
  9118.  
  9119.         # update blank line variables and count number of consecutive
  9120.         # non-blank, non-comment lines at this level
  9121.         $last_last_line_leading_level = $last_line_leading_level;
  9122.         $last_line_leading_level      = $levels_to_go[$imin];
  9123.         if ( $last_line_leading_level < 0 ) { $last_line_leading_level = 0 }
  9124.         $last_line_leading_type = $types_to_go[$imin];
  9125.         if (   $last_line_leading_level == $last_last_line_leading_level
  9126.             && $last_line_leading_type ne 'b'
  9127.             && $last_line_leading_type ne '#'
  9128.             && defined( $nonblank_lines_at_depth[$last_line_leading_level] ) )
  9129.         {
  9130.             $nonblank_lines_at_depth[$last_line_leading_level]++;
  9131.         }
  9132.         else {
  9133.             $nonblank_lines_at_depth[$last_line_leading_level] = 1;
  9134.         }
  9135.  
  9136.         FORMATTER_DEBUG_FLAG_FLUSH && do {
  9137.             my ( $package, $file, $line ) = caller;
  9138.             print
  9139. "FLUSH: flushing from $package $file $line, types= $types_to_go[$imin] to $types_to_go[$imax]\n";
  9140.         };
  9141.  
  9142.         # add a couple of extra terminal blank tokens
  9143.         pad_array_to_go();
  9144.  
  9145.         # set all forced breakpoints for good list formatting
  9146.         my $saw_good_break = 0;
  9147.         my $is_long_line   = excess_line_length( $imin, $max_index_to_go ) > 0;
  9148.  
  9149.         if (
  9150.             $max_index_to_go > 0
  9151.             && (
  9152.                    $is_long_line
  9153.                 || $old_line_count_in_batch > 1
  9154.                 || is_unbalanced_batch()
  9155.                 || (
  9156.                     $comma_count_in_batch
  9157.                     && (   $rOpts_maximum_fields_per_table > 0
  9158.                         || $rOpts_comma_arrow_breakpoints == 0 )
  9159.                 )
  9160.             )
  9161.           )
  9162.         {
  9163.             $saw_good_break = scan_list();
  9164.         }
  9165.  
  9166.         # let $ri_first and $ri_last be references to lists of
  9167.         # first and last tokens of line fragments to output..
  9168.         my ( $ri_first, $ri_last );
  9169.  
  9170.         # write a single line if..
  9171.         if (
  9172.  
  9173.             # we aren't allowed to add any newlines
  9174.             !$rOpts_add_newlines
  9175.  
  9176.             # or, we don't already have an interior breakpoint
  9177.             # and we didn't see a good breakpoint
  9178.             || (
  9179.                    !$forced_breakpoint_count
  9180.                 && !$saw_good_break
  9181.  
  9182.                 # and this line is 'short'
  9183.                 && !$is_long_line
  9184.             )
  9185.           )
  9186.         {
  9187.             @$ri_first = ($imin);
  9188.             @$ri_last  = ($imax);
  9189.         }
  9190.  
  9191.         # otherwise use multiple lines
  9192.         else {
  9193.  
  9194.             ( $ri_first, $ri_last ) = set_continuation_breaks($saw_good_break);
  9195.  
  9196.             # now we do a correction step to clean this up a bit
  9197.             # (The only time we would not do this is for debugging)
  9198.             if ( $rOpts->{'recombine'} ) {
  9199.                 ( $ri_first, $ri_last ) =
  9200.                   recombine_breakpoints( $ri_first, $ri_last );
  9201.             }
  9202.         }
  9203.  
  9204.         # do corrector step if -lp option is used
  9205.         my $do_not_pad = 0;
  9206.         if ($rOpts_line_up_parentheses) {
  9207.             $do_not_pad = correct_lp_indentation( $ri_first, $ri_last );
  9208.         }
  9209.         send_lines_to_vertical_aligner( $ri_first, $ri_last, $do_not_pad );
  9210.     }
  9211.     prepare_for_new_input_lines();
  9212.  
  9213.     # output any new -cscw block comment
  9214.     if ($cscw_block_comment) {
  9215.         flush();
  9216.         $file_writer_object->write_code_line( $cscw_block_comment . "\n" );
  9217.     }
  9218. }
  9219.  
  9220. sub reset_block_text_accumulator {
  9221.  
  9222.     # save text after 'if' and 'elsif' to append after 'else'
  9223.     if ($accumulating_text_for_block) {
  9224.  
  9225.         if ( $accumulating_text_for_block =~ /^(if|elsif)$/ ) {
  9226.             push @{$rleading_block_if_elsif_text}, $leading_block_text;
  9227.         }
  9228.     }
  9229.     $accumulating_text_for_block        = "";
  9230.     $leading_block_text                 = "";
  9231.     $leading_block_text_level           = 0;
  9232.     $leading_block_text_length_exceeded = 0;
  9233.     $leading_block_text_line_number     = 0;
  9234.     $leading_block_text_line_length     = 0;
  9235. }
  9236.  
  9237. sub set_block_text_accumulator {
  9238.     my $i = shift;
  9239.     $accumulating_text_for_block = $tokens_to_go[$i];
  9240.     if ( $accumulating_text_for_block !~ /^els/ ) {
  9241.         $rleading_block_if_elsif_text = [];
  9242.     }
  9243.     $leading_block_text             = "";
  9244.     $leading_block_text_level       = $levels_to_go[$i];
  9245.     $leading_block_text_line_number =
  9246.       $vertical_aligner_object->get_output_line_number();
  9247.     $leading_block_text_length_exceeded = 0;
  9248.  
  9249.     # this will contain the column number of the last character
  9250.     # of the closing side comment
  9251.     $leading_block_text_line_length =
  9252.       length($accumulating_text_for_block) +
  9253.       length( $rOpts->{'closing-side-comment-prefix'} ) +
  9254.       $leading_block_text_level * $rOpts_indent_columns + 3;
  9255. }
  9256.  
  9257. sub accumulate_block_text {
  9258.     my $i = shift;
  9259.  
  9260.     # accumulate leading text for -csc, ignoring any side comments
  9261.     if (   $accumulating_text_for_block
  9262.         && !$leading_block_text_length_exceeded
  9263.         && $types_to_go[$i] ne '#' )
  9264.     {
  9265.  
  9266.         my $added_length = length( $tokens_to_go[$i] );
  9267.         $added_length += 1 if $i == 0;
  9268.         my $new_line_length = $leading_block_text_line_length + $added_length;
  9269.  
  9270.         # we can add this text if we don't exceed some limits..
  9271.         if (
  9272.  
  9273.             # we must not have already exceeded the text length limit
  9274.             length($leading_block_text) <
  9275.             $rOpts_closing_side_comment_maximum_text
  9276.  
  9277.             # and either:
  9278.             # the new total line length must be below the line length limit
  9279.             # or the new length must be below the text length limit
  9280.             # (ie, we may allow one token to exceed the text length limit)
  9281.             && ( $new_line_length < $rOpts_maximum_line_length
  9282.                 || length($leading_block_text) + $added_length <
  9283.                 $rOpts_closing_side_comment_maximum_text )
  9284.  
  9285.             # UNLESS: we are adding a closing paren before the brace we seek.
  9286.             # This is an attempt to avoid situations where the ... to be
  9287.             # added are longer than the omitted right paren, as in:
  9288.  
  9289.             #   foreach my $item (@a_rather_long_variable_name_here) {
  9290.             #      &whatever;
  9291.             #   } ## end foreach my $item (@a_rather_long_variable_name_here...
  9292.  
  9293.             || (
  9294.                 $tokens_to_go[$i] eq ')'
  9295.                 && (
  9296.                     (
  9297.                            $i + 1 <= $max_index_to_go
  9298.                         && $block_type_to_go[ $i + 1 ] eq
  9299.                         $accumulating_text_for_block
  9300.                     )
  9301.                     || (   $i + 2 <= $max_index_to_go
  9302.                         && $block_type_to_go[ $i + 2 ] eq
  9303.                         $accumulating_text_for_block )
  9304.                 )
  9305.             )
  9306.           )
  9307.         {
  9308.  
  9309.             # add an extra space at each newline
  9310.             if ( $i == 0 ) { $leading_block_text .= ' ' }
  9311.  
  9312.             # add the token text
  9313.             $leading_block_text .= $tokens_to_go[$i];
  9314.             $leading_block_text_line_length = $new_line_length;
  9315.         }
  9316.  
  9317.         # show that text was truncated if necessary
  9318.         elsif ( $types_to_go[$i] ne 'b' ) {
  9319.             $leading_block_text_length_exceeded = 1;
  9320.             $leading_block_text .= '...';
  9321.         }
  9322.     }
  9323. }
  9324.  
  9325. {
  9326.     my %is_if_elsif_else_unless_while_until_for_foreach;
  9327.  
  9328.     BEGIN {
  9329.  
  9330.         # These block types may have text between the keyword and opening
  9331.         # curly.  Note: 'else' does not, but must be included to allow trailing
  9332.         # if/elsif text to be appended.
  9333.         # patch for SWITCH/CASE: added 'case' and 'when'
  9334.         @_ = qw(if elsif else unless while until for foreach case when);
  9335.         @is_if_elsif_else_unless_while_until_for_foreach{@_} = (1) x scalar(@_);
  9336.     }
  9337.  
  9338.     sub accumulate_csc_text {
  9339.  
  9340.         # called once per output buffer when -csc is used. Accumulates
  9341.         # the text placed after certain closing block braces.
  9342.         # Defines and returns the following for this buffer:
  9343.  
  9344.         my $block_leading_text = "";    # the leading text of the last '}'
  9345.         my $rblock_leading_if_elsif_text;
  9346.         my $i_block_leading_text =
  9347.           -1;    # index of token owning block_leading_text
  9348.         my $block_line_count    = 100;    # how many lines the block spans
  9349.         my $terminal_type       = 'b';    # type of last nonblank token
  9350.         my $i_terminal          = 0;      # index of last nonblank token
  9351.         my $terminal_block_type = "";
  9352.  
  9353.         for my $i ( 0 .. $max_index_to_go ) {
  9354.             my $type       = $types_to_go[$i];
  9355.             my $block_type = $block_type_to_go[$i];
  9356.             my $token      = $tokens_to_go[$i];
  9357.  
  9358.             # remember last nonblank token type
  9359.             if ( $type ne '#' && $type ne 'b' ) {
  9360.                 $terminal_type       = $type;
  9361.                 $terminal_block_type = $block_type;
  9362.                 $i_terminal          = $i;
  9363.             }
  9364.  
  9365.             my $type_sequence = $type_sequence_to_go[$i];
  9366.             if ( $block_type && $type_sequence ) {
  9367.  
  9368.                 if ( $token eq '}' ) {
  9369.  
  9370.                     # restore any leading text saved when we entered this block
  9371.                     if ( defined( $block_leading_text{$type_sequence} ) ) {
  9372.                         ( $block_leading_text, $rblock_leading_if_elsif_text ) =
  9373.                           @{ $block_leading_text{$type_sequence} };
  9374.                         $i_block_leading_text = $i;
  9375.                         delete $block_leading_text{$type_sequence};
  9376.                         $rleading_block_if_elsif_text =
  9377.                           $rblock_leading_if_elsif_text;
  9378.                     }
  9379.  
  9380.                     # if we run into a '}' then we probably started accumulating
  9381.                     # at something like a trailing 'if' clause..no harm done.
  9382.                     if (   $accumulating_text_for_block
  9383.                         && $levels_to_go[$i] <= $leading_block_text_level )
  9384.                     {
  9385.                         my $lev = $levels_to_go[$i];
  9386.                         reset_block_text_accumulator();
  9387.                     }
  9388.  
  9389.                     if ( defined( $block_opening_line_number{$type_sequence} ) )
  9390.                     {
  9391.                         my $output_line_number =
  9392.                           $vertical_aligner_object->get_output_line_number();
  9393.                         $block_line_count = $output_line_number -
  9394.                           $block_opening_line_number{$type_sequence} + 1;
  9395.                         delete $block_opening_line_number{$type_sequence};
  9396.                     }
  9397.                     else {
  9398.  
  9399.                         # Error: block opening line undefined for this line..
  9400.                         # This shouldn't be possible, but it is not a
  9401.                         # significant problem.
  9402.                     }
  9403.                 }
  9404.  
  9405.                 elsif ( $token eq '{' ) {
  9406.  
  9407.                     my $line_number =
  9408.                       $vertical_aligner_object->get_output_line_number();
  9409.                     $block_opening_line_number{$type_sequence} = $line_number;
  9410.  
  9411.                     if (   $accumulating_text_for_block
  9412.                         && $levels_to_go[$i] == $leading_block_text_level )
  9413.                     {
  9414.  
  9415.                         if ( $accumulating_text_for_block eq $block_type ) {
  9416.  
  9417.                             # save any leading text before we enter this block
  9418.                             $block_leading_text{$type_sequence} = [
  9419.                                 $leading_block_text,
  9420.                                 $rleading_block_if_elsif_text
  9421.                             ];
  9422.                             $block_opening_line_number{$type_sequence} =
  9423.                               $leading_block_text_line_number;
  9424.                             reset_block_text_accumulator();
  9425.                         }
  9426.                         else {
  9427.  
  9428.                             # shouldn't happen, but not a serious error.
  9429.                             # We were accumulating -csc text for block type
  9430.                             # $accumulating_text_for_block and unexpectedly
  9431.                             # encountered a '{' for block type $block_type.
  9432.                         }
  9433.                     }
  9434.                 }
  9435.             }
  9436.  
  9437.             if (
  9438.                    $type eq 'k'
  9439.                 && $csc_new_statement_ok
  9440.  
  9441.                 #  /^(else|if|elsif|unless|while|until|for|foreach)$/
  9442.                 && $is_if_elsif_else_unless_while_until_for_foreach{$token}
  9443.                 && $token =~ /$closing_side_comment_list_pattern/o
  9444.               )
  9445.             {
  9446.                 set_block_text_accumulator($i);
  9447.             }
  9448.             else {
  9449.  
  9450.                 # note: ignoring type 'q' because of tricks being played
  9451.                 # with 'q' for hanging side comments
  9452.                 if ( $type ne 'b' && $type ne '#' && $type ne 'q' ) {
  9453.                     $csc_new_statement_ok =
  9454.                       ( $block_type || $type eq 'J' || $type eq ';' );
  9455.                 }
  9456.                 if (   $type eq ';'
  9457.                     && $accumulating_text_for_block
  9458.                     && $levels_to_go[$i] == $leading_block_text_level )
  9459.                 {
  9460.                     reset_block_text_accumulator();
  9461.                 }
  9462.                 else {
  9463.                     accumulate_block_text($i);
  9464.                 }
  9465.             }
  9466.         }
  9467.  
  9468.         # Treat an 'else' block specially by adding preceding 'if' and
  9469.         # 'elsif' text.  Otherwise, the 'end else' is not helpful,
  9470.         # especially for cuddled-else formatting.
  9471.         if ( $terminal_block_type =~ /^els/ && $rblock_leading_if_elsif_text ) {
  9472.             $block_leading_text =
  9473.               make_else_csc_text( $i_terminal, $terminal_block_type,
  9474.                 $block_leading_text, $rblock_leading_if_elsif_text );
  9475.         }
  9476.  
  9477.         return ( $terminal_type, $i_terminal, $i_block_leading_text,
  9478.             $block_leading_text, $block_line_count );
  9479.     }
  9480. }
  9481.  
  9482. sub make_else_csc_text {
  9483.  
  9484.     # create additional -csc text for an 'else' and optionally 'elsif',
  9485.     # depending on the value of switch
  9486.     # $rOpts_closing_side_comment_else_flag:
  9487.     #
  9488.     #  = 0 add 'if' text to trailing else
  9489.     #  = 1 same as 0 plus:
  9490.     #      add 'if' to 'elsif's if can fit in line length
  9491.     #      add last 'elsif' to trailing else if can fit in one line
  9492.     #  = 2 same as 1 but do not check if exceed line length
  9493.     #
  9494.     # $rif_elsif_text = a reference to a list of all previous closing
  9495.     # side comments created for this if block
  9496.     #
  9497.     my ( $i_terminal, $block_type, $block_leading_text, $rif_elsif_text ) = @_;
  9498.     my $csc_text = $block_leading_text;
  9499.  
  9500.     if ( $block_type eq 'elsif' && $rOpts_closing_side_comment_else_flag == 0 )
  9501.     {
  9502.         return $csc_text;
  9503.     }
  9504.  
  9505.     my $count = @{$rif_elsif_text};
  9506.     return $csc_text unless ($count);
  9507.  
  9508.     my $if_text = '[ if' . $rif_elsif_text->[0];
  9509.  
  9510.     # always show the leading 'if' text on 'else'
  9511.     if ( $block_type eq 'else' ) {
  9512.         $csc_text .= $if_text;
  9513.     }
  9514.  
  9515.     # see if that's all
  9516.     if ( $rOpts_closing_side_comment_else_flag == 0 ) {
  9517.         return $csc_text;
  9518.     }
  9519.  
  9520.     my $last_elsif_text = "";
  9521.     if ( $count > 1 ) {
  9522.         $last_elsif_text = ' [elsif' . $rif_elsif_text->[ $count - 1 ];
  9523.         if ( $count > 2 ) { $last_elsif_text = ' [...' . $last_elsif_text; }
  9524.     }
  9525.  
  9526.     # tentatively append one more item
  9527.     my $saved_text = $csc_text;
  9528.     if ( $block_type eq 'else' ) {
  9529.         $csc_text .= $last_elsif_text;
  9530.     }
  9531.     else {
  9532.         $csc_text .= ' ' . $if_text;
  9533.     }
  9534.  
  9535.     # all done if no length checks requested
  9536.     if ( $rOpts_closing_side_comment_else_flag == 2 ) {
  9537.         return $csc_text;
  9538.     }
  9539.  
  9540.     # undo it if line length exceeded
  9541.     my $length =
  9542.       length($csc_text) + length($block_type) +
  9543.       length( $rOpts->{'closing-side-comment-prefix'} ) +
  9544.       $levels_to_go[$i_terminal] * $rOpts_indent_columns + 3;
  9545.     if ( $length > $rOpts_maximum_line_length ) {
  9546.         $csc_text = $saved_text;
  9547.     }
  9548.     return $csc_text;
  9549. }
  9550.  
  9551. sub add_closing_side_comment {
  9552.  
  9553.     # add closing side comments after closing block braces if -csc used
  9554.     my $cscw_block_comment;
  9555.  
  9556.     #---------------------------------------------------------------
  9557.     # Step 1: loop through all tokens of this line to accumulate
  9558.     # the text needed to create the closing side comments. Also see
  9559.     # how the line ends.
  9560.     #---------------------------------------------------------------
  9561.  
  9562.     my ( $terminal_type, $i_terminal, $i_block_leading_text,
  9563.         $block_leading_text, $block_line_count )
  9564.       = accumulate_csc_text();
  9565.  
  9566.     #---------------------------------------------------------------
  9567.     # Step 2: make the closing side comment if this ends a block
  9568.     #---------------------------------------------------------------
  9569.     my $have_side_comment = $i_terminal != $max_index_to_go;
  9570.  
  9571.     # if this line might end in a block closure..
  9572.     if (
  9573.         $terminal_type eq '}'
  9574.  
  9575.         # ..and either
  9576.         && (
  9577.  
  9578.             # the block is long enough
  9579.             ( $block_line_count >= $rOpts->{'closing-side-comment-interval'} )
  9580.  
  9581.             # or there is an existing comment to check
  9582.             || (   $have_side_comment
  9583.                 && $rOpts->{'closing-side-comment-warnings'} )
  9584.         )
  9585.  
  9586.         # .. and if this is one of the types of interest
  9587.         && $block_type_to_go[$i_terminal] =~
  9588.         /$closing_side_comment_list_pattern/o
  9589.  
  9590.         # ..and the corresponding opening brace must is not in this batch
  9591.         # (because we do not need to tag one-line blocks, although this
  9592.         # should also be caught with a positive -csci value)
  9593.         && $mate_index_to_go[$i_terminal] < 0
  9594.  
  9595.         # ..and either
  9596.         && (
  9597.  
  9598.             # this is the last token (line doesnt have a side comment)
  9599.             !$have_side_comment
  9600.  
  9601.             # or the old side comment is a closing side comment
  9602.             || $tokens_to_go[$max_index_to_go] =~
  9603.             /$closing_side_comment_prefix_pattern/o
  9604.         )
  9605.       )
  9606.     {
  9607.  
  9608.         # then make the closing side comment text
  9609.         my $token =
  9610. "$rOpts->{'closing-side-comment-prefix'} $block_type_to_go[$i_terminal]";
  9611.  
  9612.         # append any extra descriptive text collected above
  9613.         if ( $i_block_leading_text == $i_terminal ) {
  9614.             $token .= $block_leading_text;
  9615.         }
  9616.         $token =~ s/\s*$//;    # trim any trailing whitespace
  9617.  
  9618.         # handle case of existing closing side comment
  9619.         if ($have_side_comment) {
  9620.  
  9621.             # warn if requested and tokens differ significantly
  9622.             if ( $rOpts->{'closing-side-comment-warnings'} ) {
  9623.                 my $old_csc = $tokens_to_go[$max_index_to_go];
  9624.                 my $new_csc = $token;
  9625.                 $new_csc =~ s/(\.\.\.)\s*$//;    # trim trailing '...'
  9626.                 my $new_trailing_dots = $1;
  9627.                 $old_csc =~ s/\.\.\.\s*$//;
  9628.                 $new_csc =~ s/\s+//g;            # trim all whitespace
  9629.                 $old_csc =~ s/\s+//g;
  9630.  
  9631.                 # Patch to handle multiple closing side comments at
  9632.                 # else and elsif's.  These have become too complicated
  9633.                 # to check, so if we see an indication of
  9634.                 # '[ if' or '[ # elsif', then assume they were made
  9635.                 # by perltidy.
  9636.                 if ( $block_type_to_go[$i_terminal] eq 'else' ) {
  9637.                     if ( $old_csc =~ /\[\s*elsif/ ) { $old_csc = $new_csc }
  9638.                 }
  9639.                 elsif ( $block_type_to_go[$i_terminal] eq 'elsif' ) {
  9640.                     if ( $old_csc =~ /\[\s*if/ ) { $old_csc = $new_csc }
  9641.                 }
  9642.  
  9643.                 # if old comment is contained in new comment,
  9644.                 # only compare the common part.
  9645.                 if ( length($new_csc) > length($old_csc) ) {
  9646.                     $new_csc = substr( $new_csc, 0, length($old_csc) );
  9647.                 }
  9648.  
  9649.                 # if the new comment is shorter and has been limited,
  9650.                 # only compare the common part.
  9651.                 if ( length($new_csc) < length($old_csc) && $new_trailing_dots )
  9652.                 {
  9653.                     $old_csc = substr( $old_csc, 0, length($new_csc) );
  9654.                 }
  9655.  
  9656.                 # any remaining difference?
  9657.                 if ( $new_csc ne $old_csc ) {
  9658.  
  9659.                     # just leave the old comment if we are below the threshold
  9660.                     # for creating side comments
  9661.                     if ( $block_line_count <
  9662.                         $rOpts->{'closing-side-comment-interval'} )
  9663.                     {
  9664.                         $token = undef;
  9665.                     }
  9666.  
  9667.                     # otherwise we'll make a note of it
  9668.                     else {
  9669.  
  9670.                         warning(
  9671. "perltidy -cscw replaced: $tokens_to_go[$max_index_to_go]\n"
  9672.                         );
  9673.  
  9674.                      # save the old side comment in a new trailing block comment
  9675.                         my ( $day, $month, $year ) = (localtime)[ 3, 4, 5 ];
  9676.                         $year  += 1900;
  9677.                         $month += 1;
  9678.                         $cscw_block_comment =
  9679. "## perltidy -cscw $year-$month-$day: $tokens_to_go[$max_index_to_go]";
  9680.                     }
  9681.                 }
  9682.                 else {
  9683.  
  9684.                     # No differences.. we can safely delete old comment if we
  9685.                     # are below the threshold
  9686.                     if ( $block_line_count <
  9687.                         $rOpts->{'closing-side-comment-interval'} )
  9688.                     {
  9689.                         $token = undef;
  9690.                         unstore_token_to_go()
  9691.                           if ( $types_to_go[$max_index_to_go] eq '#' );
  9692.                         unstore_token_to_go()
  9693.                           if ( $types_to_go[$max_index_to_go] eq 'b' );
  9694.                     }
  9695.                 }
  9696.             }
  9697.  
  9698.             # switch to the new csc (unless we deleted it!)
  9699.             $tokens_to_go[$max_index_to_go] = $token if $token;
  9700.         }
  9701.  
  9702.         # handle case of NO existing closing side comment
  9703.         else {
  9704.  
  9705.             # insert the new side comment into the output token stream
  9706.             my $type                  = '#';
  9707.             my $block_type            = '';
  9708.             my $type_sequence         = '';
  9709.             my $container_environment =
  9710.               $container_environment_to_go[$max_index_to_go];
  9711.             my $level                = $levels_to_go[$max_index_to_go];
  9712.             my $slevel               = $nesting_depth_to_go[$max_index_to_go];
  9713.             my $no_internal_newlines = 0;
  9714.  
  9715.             my $nesting_blocks     = $nesting_blocks_to_go[$max_index_to_go];
  9716.             my $ci_level           = $ci_levels_to_go[$max_index_to_go];
  9717.             my $in_continued_quote = 0;
  9718.  
  9719.             # first insert a blank token
  9720.             insert_new_token_to_go( ' ', 'b', $slevel, $no_internal_newlines );
  9721.  
  9722.             # then the side comment
  9723.             insert_new_token_to_go( $token, $type, $slevel,
  9724.                 $no_internal_newlines );
  9725.         }
  9726.     }
  9727.     return $cscw_block_comment;
  9728. }
  9729.  
  9730. sub previous_nonblank_token {
  9731.     my ($i) = @_;
  9732.     if ( $i <= 0 ) {
  9733.         return "";
  9734.     }
  9735.     elsif ( $types_to_go[ $i - 1 ] ne 'b' ) {
  9736.         return $tokens_to_go[ $i - 1 ];
  9737.     }
  9738.     elsif ( $i > 1 ) {
  9739.         return $tokens_to_go[ $i - 2 ];
  9740.     }
  9741.     else {
  9742.         return "";
  9743.     }
  9744. }
  9745.  
  9746. sub send_lines_to_vertical_aligner {
  9747.  
  9748.     my ( $ri_first, $ri_last, $do_not_pad ) = @_;
  9749.  
  9750.     my $rindentation_list = [0];    # ref to indentations for each line
  9751.  
  9752.     set_vertical_alignment_markers( $ri_first, $ri_last );
  9753.  
  9754.     # flush if necessary to avoid unwanted alignment
  9755.     my $must_flush = 0;
  9756.     if ( @$ri_first > 1 ) {
  9757.  
  9758.         # flush before a long if statement
  9759.         if ( $types_to_go[0] eq 'k' && $tokens_to_go[0] =~ /^(if|unless)$/ ) {
  9760.             $must_flush = 1;
  9761.         }
  9762.     }
  9763.     if ($must_flush) {
  9764.         Perl::Tidy::VerticalAligner::flush();
  9765.     }
  9766.  
  9767.     set_logical_padding( $ri_first, $ri_last );
  9768.  
  9769.     # loop to prepare each line for shipment
  9770.     my $n_last_line = @$ri_first - 1;
  9771.     for my $n ( 0 .. $n_last_line ) {
  9772.         my $ibeg = $$ri_first[$n];
  9773.         my $iend = $$ri_last[$n];
  9774.  
  9775.         my @patterns = ();
  9776.         my @tokens   = ();
  9777.         my @fields   = ();
  9778.         my $i_start  = $ibeg;
  9779.         my $i;
  9780.  
  9781.         my $depth                 = 0;
  9782.         my @container_name        = ("");
  9783.         my @multiple_comma_arrows = (undef);
  9784.  
  9785.         my $j = 0;    # field index
  9786.  
  9787.         $patterns[0] = "";
  9788.         for $i ( $ibeg .. $iend ) {
  9789.  
  9790.             # Keep track of containers balanced on this line only.
  9791.             # These are used below to prevent unwanted cross-line alignments.
  9792.             # Unbalanced containers already avoid aligning across
  9793.             # container boundaries.
  9794.             if ( $tokens_to_go[$i] eq '(' ) {
  9795.                 my $i_mate = $mate_index_to_go[$i];
  9796.                 if ( $i_mate > $i && $i_mate <= $iend ) {
  9797.                     $depth++;
  9798.                     my $seqno = $type_sequence_to_go[$i];
  9799.                     my $count = comma_arrow_count($seqno);
  9800.                     $multiple_comma_arrows[$depth] = $count && $count > 1;
  9801.                     my $name = previous_nonblank_token($i);
  9802.                     $name =~ s/^->//;
  9803.                     $container_name[$depth] = "+" . $name;
  9804.                 }
  9805.             }
  9806.             elsif ( $tokens_to_go[$i] eq ')' ) {
  9807.                 $depth-- if $depth > 0;
  9808.             }
  9809.  
  9810.             # if we find a new synchronization token, we are done with
  9811.             # a field
  9812.             if ( $i > $i_start && $matching_token_to_go[$i] ne '' ) {
  9813.  
  9814.                 my $tok = my $raw_tok = $matching_token_to_go[$i];
  9815.  
  9816.                 # make separators in different nesting depths unique
  9817.                 # by appending the nesting depth digit.
  9818.                 if ( $raw_tok ne '#' ) {
  9819.                     $tok .= "$nesting_depth_to_go[$i]";
  9820.                 }
  9821.  
  9822.                 # do any special decorations for commas to avoid unwanted
  9823.                 # cross-line alignments.
  9824.                 if ( $raw_tok eq ',' ) {
  9825.                     if ( $container_name[$depth] ) {
  9826.                         $tok .= $container_name[$depth];
  9827.                     }
  9828.                 }
  9829.  
  9830.                 # decorate '=>' with:
  9831.                 # - Nothing if this container is unbalanced on this line.
  9832.                 # - The previous token if it is balanced and multiple '=>'s
  9833.                 # - The container name if it is bananced and no other '=>'s
  9834.                 elsif ( $raw_tok eq '=>' ) {
  9835.                     if ( $container_name[$depth] ) {
  9836.                         if ( $multiple_comma_arrows[$depth] ) {
  9837.                             $tok .= "+" . previous_nonblank_token($i);
  9838.                         }
  9839.                         else {
  9840.                             $tok .= $container_name[$depth];
  9841.                         }
  9842.                     }
  9843.                 }
  9844.  
  9845.                 # concatenate the text of the consecutive tokens to form
  9846.                 # the field
  9847.                 push ( @fields,
  9848.                     join ( '', @tokens_to_go[ $i_start .. $i - 1 ] ) );
  9849.  
  9850.                 # store the alignment token for this field
  9851.                 push ( @tokens, $tok );
  9852.  
  9853.                 # get ready for the next batch
  9854.                 $i_start = $i;
  9855.                 $j++;
  9856.                 $patterns[$j] = "";
  9857.             }
  9858.  
  9859.             # continue accumulating tokens
  9860.             # handle non-keywords..
  9861.             if ( $types_to_go[$i] ne 'k' ) {
  9862.                 my $type = $types_to_go[$i];
  9863.  
  9864.                 # Mark most things before arrows as a quote to
  9865.                 # get them to line up. Testfile: mixed.pl.
  9866.                 if ( ( $i < $iend - 1 ) && ( $type =~ /^[wnC]$/ ) ) {
  9867.                     my $next_type       = $types_to_go[ $i + 1 ];
  9868.                     my $i_next_nonblank =
  9869.                       ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
  9870.  
  9871.                     if ( $types_to_go[$i_next_nonblank] eq '=>' ) {
  9872.                         $type = 'Q';
  9873.                     }
  9874.                 }
  9875.  
  9876.                 # minor patch to make numbers and quotes align
  9877.                 if ( $type eq 'n' ) { $type = 'Q' }
  9878.  
  9879.                 $patterns[$j] .= $type;
  9880.             }
  9881.  
  9882.             # for keywords we have to use the actual text
  9883.             else {
  9884.  
  9885.                 # map certain keywords to the same 'if' class to align
  9886.                 # long if/elsif sequences. my testfile: elsif.pl
  9887.                 my $tok = $tokens_to_go[$i];
  9888.                 if ( $n == 0 && $tok =~ /^(elsif|else|unless)$/ ) {
  9889.                     $tok = 'if';
  9890.                 }
  9891.                 $patterns[$j] .= $tok;
  9892.             }
  9893.         }
  9894.  
  9895.         # done with this line .. join text of tokens to make the last field
  9896.         push ( @fields, join ( '', @tokens_to_go[ $i_start .. $iend ] ) );
  9897.  
  9898.         my ( $indentation, $lev, $level_end, $is_semicolon_terminated,
  9899.             $is_outdented_line )
  9900.           = set_adjusted_indentation( $ibeg, $iend, \@fields, \@patterns,
  9901.             $ri_first, $ri_last, $rindentation_list );
  9902.  
  9903.         # we will allow outdenting of long lines..
  9904.         my $outdent_long_lines = (
  9905.  
  9906.             # which are long quotes, if allowed
  9907.             ( $types_to_go[$ibeg] eq 'Q' && $rOpts->{'outdent-long-quotes'} )
  9908.  
  9909.             # which are long block comments, if allowed
  9910.               || (
  9911.                    $types_to_go[$ibeg] eq '#'
  9912.                 && $rOpts->{'outdent-long-comments'}
  9913.  
  9914.                 # but not if this is a static block comment
  9915.                 && !(
  9916.                        $rOpts->{'static-block-comments'}
  9917.                     && $tokens_to_go[$ibeg] =~ /$static_block_comment_pattern/o
  9918.                 )
  9919.               )
  9920.         );
  9921.  
  9922.         my $level_jump =
  9923.           $nesting_depth_to_go[ $iend + 1 ] - $nesting_depth_to_go[$ibeg];
  9924.  
  9925.         my $rvertical_tightness_flags =
  9926.           set_vertical_tightness_flags( $n, $n_last_line, $ibeg, $iend,
  9927.             $ri_first, $ri_last );
  9928.  
  9929.         # flush an outdented line to avoid any unwanted vertical alignment
  9930.         Perl::Tidy::VerticalAligner::flush() if ($is_outdented_line);
  9931.  
  9932.         # send this new line down the pipe
  9933.         Perl::Tidy::VerticalAligner::append_line(
  9934.             $lev,                            $level_end,
  9935.             $indentation,                    \@fields,
  9936.             \@tokens,                        \@patterns,
  9937.             $forced_breakpoint_to_go[$iend], $outdent_long_lines,
  9938.             $is_semicolon_terminated,        $do_not_pad,
  9939.             $rvertical_tightness_flags,      $level_jump,
  9940.         );
  9941.  
  9942.         # flush an outdented line to avoid any unwanted vertical alignment
  9943.         Perl::Tidy::VerticalAligner::flush() if ($is_outdented_line);
  9944.  
  9945.         $do_not_pad = 0;
  9946.  
  9947.     }    # end of loop to output each line
  9948.  
  9949.     # remember indentation of lines containing opening containers for
  9950.     # later use by sub set_adjusted_indentation
  9951.     save_opening_indentation( $ri_first, $ri_last, $rindentation_list );
  9952. }
  9953.  
  9954. {        # begin unmatched_indexes
  9955.  
  9956.     # closure to keep track of unbalanced containers.
  9957.     # arrays shared by the routines in this block:
  9958.     my @unmatched_opening_indexes_in_this_batch;
  9959.     my @unmatched_closing_indexes_in_this_batch;
  9960.     my %comma_arrow_count;
  9961.  
  9962.     sub is_unbalanced_batch {
  9963.         @unmatched_opening_indexes_in_this_batch +
  9964.           @unmatched_closing_indexes_in_this_batch;
  9965.     }
  9966.  
  9967.     sub comma_arrow_count {
  9968.         my $seqno = $_[0];
  9969.         return $comma_arrow_count{$seqno};
  9970.     }
  9971.  
  9972.     sub match_opening_and_closing_tokens {
  9973.  
  9974.         # Match up indexes of opening and closing braces, etc, in this batch.
  9975.         # This has to be done after all tokens are stored because unstoring
  9976.         # of tokens would otherwise cause trouble.
  9977.  
  9978.         @unmatched_opening_indexes_in_this_batch = ();
  9979.         @unmatched_closing_indexes_in_this_batch = ();
  9980.         %comma_arrow_count                       = ();
  9981.  
  9982.         my ( $i, $i_mate, $token );
  9983.         foreach $i ( 0 .. $max_index_to_go ) {
  9984.             if ( $type_sequence_to_go[$i] ) {
  9985.                 $token = $tokens_to_go[$i];
  9986.                 if ( $token =~ /^[\(\[\{\?]$/ ) {
  9987.                     push @unmatched_opening_indexes_in_this_batch, $i;
  9988.                 }
  9989.                 elsif ( $token =~ /^[\)\]\}\:]$/ ) {
  9990.  
  9991.                     $i_mate = pop @unmatched_opening_indexes_in_this_batch;
  9992.                     if ( defined($i_mate) && $i_mate >= 0 ) {
  9993.                         if ( $type_sequence_to_go[$i_mate] ==
  9994.                             $type_sequence_to_go[$i] )
  9995.                         {
  9996.                             $mate_index_to_go[$i]      = $i_mate;
  9997.                             $mate_index_to_go[$i_mate] = $i;
  9998.                         }
  9999.                         else {
  10000.                             push @unmatched_opening_indexes_in_this_batch,
  10001.                               $i_mate;
  10002.                             push @unmatched_closing_indexes_in_this_batch, $i;
  10003.                         }
  10004.                     }
  10005.                     else {
  10006.                         push @unmatched_closing_indexes_in_this_batch, $i;
  10007.                     }
  10008.                 }
  10009.             }
  10010.             elsif ( $tokens_to_go[$i] eq '=>' ) {
  10011.                 if (@unmatched_opening_indexes_in_this_batch) {
  10012.                     my $j     = $unmatched_opening_indexes_in_this_batch[-1];
  10013.                     my $seqno = $type_sequence_to_go[$j];
  10014.                     $comma_arrow_count{$seqno}++;
  10015.                 }
  10016.             }
  10017.         }
  10018.     }
  10019.  
  10020.     sub save_opening_indentation {
  10021.  
  10022.         # This should be called after each batch of tokens is output. It
  10023.         # saves indentations of lines of all unmatched opening tokens.
  10024.         # These will be used by sub get_opening_indentation.
  10025.  
  10026.         my ( $ri_first, $ri_last, $rindentation_list ) = @_;
  10027.  
  10028.         # we no longer need indentations of any saved indentations which
  10029.         # are unmatched closing tokens in this batch, because we will
  10030.         # never encounter them again.  So we can delete them to keep
  10031.         # the hash size down.
  10032.         foreach (@unmatched_closing_indexes_in_this_batch) {
  10033.             my $seqno = $type_sequence_to_go[$_];
  10034.             delete $saved_opening_indentation{$seqno};
  10035.         }
  10036.  
  10037.         # we need to save indentations of any unmatched opening tokens
  10038.         # in this batch because we may need them in a subsequent batch.
  10039.         foreach (@unmatched_opening_indexes_in_this_batch) {
  10040.             my $seqno = $type_sequence_to_go[$_];
  10041.             $saved_opening_indentation{$seqno} = [
  10042.                 lookup_opening_indentation(
  10043.                     $_, $ri_first, $ri_last, $rindentation_list
  10044.                 )
  10045.             ];
  10046.         }
  10047.     }
  10048. }    # end unmatched_indexes
  10049.  
  10050. sub get_opening_indentation {
  10051.  
  10052.     # get the indentation of the line which output the opening token
  10053.     # corresponding to a given closing token in the current output batch.
  10054.     #
  10055.     # given:
  10056.     # $i_closing - index in this line of a closing token ')' '}' or ']'
  10057.     #
  10058.     # $ri_first - reference to list of the first index $i for each output
  10059.     #               line in this batch
  10060.     # $ri_last - reference to list of the last index $i for each output line
  10061.     #              in this batch
  10062.     # $rindentation_list - reference to a list containing the indentation
  10063.     #            used for each line.
  10064.     #
  10065.     # return:
  10066.     #   -the indentation of the line which contained the opening token
  10067.     #    which matches the token at index $i_opening
  10068.     #   -and its offset (number of columns) from the start of the line
  10069.     #
  10070.     my ( $i_closing, $ri_first, $ri_last, $rindentation_list ) = @_;
  10071.  
  10072.     # first, see if the opening token is in the current batch
  10073.     my $i_opening = $mate_index_to_go[$i_closing];
  10074.     my ( $indent, $offset );
  10075.     if ( $i_opening >= 0 ) {
  10076.  
  10077.         # it is..look up the indentation
  10078.         ( $indent, $offset ) =
  10079.           lookup_opening_indentation( $i_opening, $ri_first, $ri_last,
  10080.             $rindentation_list );
  10081.     }
  10082.  
  10083.     # if not, it should have been stored in the hash by a previous batch
  10084.     else {
  10085.         my $seqno = $type_sequence_to_go[$i_closing];
  10086.         if ($seqno) {
  10087.             if ( $saved_opening_indentation{$seqno} ) {
  10088.                 ( $indent, $offset ) = @{ $saved_opening_indentation{$seqno} };
  10089.             }
  10090.         }
  10091.     }
  10092.     return ( $indent, $offset );
  10093. }
  10094.  
  10095. sub lookup_opening_indentation {
  10096.  
  10097.     # get the indentation of the line in the current output batch
  10098.     # which output a selected opening token
  10099.     #
  10100.     # given:
  10101.     #   $i_opening - index of an opening token in the current output batch
  10102.     #                whose line indentation we need
  10103.     #   $ri_first - reference to list of the first index $i for each output
  10104.     #               line in this batch
  10105.     #   $ri_last - reference to list of the last index $i for each output line
  10106.     #              in this batch
  10107.     #   $rindentation_list - reference to a list containing the indentation
  10108.     #            used for each line.  (NOTE: the first slot in
  10109.     #            this list is the last returned line number, and this is
  10110.     #            followed by the list of indentations).
  10111.     #
  10112.     # return
  10113.     #   -the indentation of the line which contained token $i_opening
  10114.     #   -and its offset (number of columns) from the start of the line
  10115.  
  10116.     my ( $i_opening, $ri_start, $ri_last, $rindentation_list ) = @_;
  10117.  
  10118.     my $nline = $rindentation_list->[0];    # line number of previous lookup
  10119.  
  10120.     # reset line location if necessary
  10121.     $nline = 0 if ( $i_opening < $ri_start->[$nline] );
  10122.  
  10123.     # find the correct line
  10124.     unless ( $i_opening > $ri_last->[-1] ) {
  10125.         while ( $i_opening > $ri_last->[$nline] ) { $nline++; }
  10126.     }
  10127.  
  10128.     # error - token index is out of bounds - shouldn't happen
  10129.     else {
  10130.         warning(
  10131. "non-fatal program bug in lookup_opening_indentation - index out of range\n"
  10132.         );
  10133.         report_definite_bug();
  10134.         $nline = $#{$ri_last};
  10135.     }
  10136.  
  10137.     $rindentation_list->[0] =
  10138.       $nline;    # save line number to start looking next call
  10139.     my $ibeg = $ri_start->[$nline];
  10140.     my $offset = token_sequence_length( $ibeg, $i_opening ) - 1;
  10141.     return ( $rindentation_list->[ $nline + 1 ], $offset );
  10142. }
  10143.  
  10144. sub set_adjusted_indentation {
  10145.  
  10146.     # This routine has the final say regarding the actual indentation of
  10147.     # a line.  It starts with the basic indentation which has been
  10148.     # defined for the leading token, and then takes into account any
  10149.     # options that the user has set regarding special indenting and
  10150.     # outdenting.
  10151.  
  10152.     my ( $ibeg, $iend, $rfields, $rpatterns, $ri_first, $ri_last,
  10153.         $rindentation_list )
  10154.       = @_;
  10155.  
  10156.     # we need to know the last token of this line
  10157.     my ( $terminal_type, $i_terminal ) =
  10158.       terminal_type( \@types_to_go, \@block_type_to_go, $ibeg, $iend );
  10159.  
  10160.     my $is_outdented_line = 0;
  10161.  
  10162.     my $is_semicolon_terminated = $terminal_type eq ';'
  10163.       && $nesting_depth_to_go[$iend] < $nesting_depth_to_go[$ibeg];
  10164.  
  10165.     # Most lines are indented according to the initial token.
  10166.     # But it is common to outdent to the level just after the
  10167.     # terminal token in certain cases...
  10168.     # adjust_indentation flag:
  10169.     #       0 - do not adjust
  10170.     #       1 - outdent
  10171.     #      -1 - indent
  10172.     my $adjust_indentation = 0;
  10173.  
  10174.     my ( $opening_indentation, $opening_offset );
  10175.  
  10176.     # if we are at a closing token of some type..
  10177.     if ( $types_to_go[$ibeg] =~ /^[\)\}\]]$/ ) {
  10178.  
  10179.         # get the indentation of the line containing the corresponding
  10180.         # opening token
  10181.         ( $opening_indentation, $opening_offset ) =
  10182.           get_opening_indentation( $ibeg, $ri_first, $ri_last,
  10183.             $rindentation_list );
  10184.  
  10185.         # First set the default behavior:
  10186.         # default behavior is to outdent closing lines
  10187.         # of the form:   ");  };  ];  )->xxx;"
  10188.         if (
  10189.             $is_semicolon_terminated
  10190.  
  10191.             # and 'cuddled parens' of the form:   ")->pack("
  10192.             || (
  10193.                    $terminal_type      eq '('
  10194.                 && $types_to_go[$ibeg] eq ')'
  10195.                 && ( $nesting_depth_to_go[$iend] + 1 ==
  10196.                     $nesting_depth_to_go[$ibeg] )
  10197.             )
  10198.           )
  10199.         {
  10200.             $adjust_indentation = 1;
  10201.         }
  10202.  
  10203.         # TESTING: outdent something like '),'
  10204.         if (
  10205.             $terminal_type eq ','
  10206.  
  10207.             # allow just one character before the comma
  10208.             && $i_terminal == $ibeg + 1
  10209.  
  10210.             # requre LIST environment; otherwise, we may outdent too much --
  10211.             # this can happen in calls without parentheses (overload.t);
  10212.             && $container_environment_to_go[$i_terminal] eq 'LIST'
  10213.           )
  10214.         {
  10215.             $adjust_indentation = 1;
  10216.         }
  10217.  
  10218.         # undo continuation indentation of a terminal closing token if
  10219.         # it is the last token before a level decrease.  This will allow
  10220.         # a closing token to line up with its opening counterpart, and
  10221.         # avoids a indentation jump larger than 1 level.
  10222.         if (   $types_to_go[$i_terminal] =~ /^[\}\]\)R]$/
  10223.             && $i_terminal == $ibeg )
  10224.         {
  10225.             my $ci              = $ci_levels_to_go[$ibeg];
  10226.             my $lev             = $levels_to_go[$ibeg];
  10227.             my $next_type       = $types_to_go[ $ibeg + 1 ];
  10228.             my $i_next_nonblank =
  10229.               ( ( $next_type eq 'b' ) ? $ibeg + 2 : $ibeg + 1 );
  10230.             if (   $i_next_nonblank <= $max_index_to_go
  10231.                 && $levels_to_go[$i_next_nonblank] < $lev )
  10232.             {
  10233.                 $adjust_indentation = 1;
  10234.             }
  10235.         }
  10236.  
  10237.         # Now modify default behavior according to user request:
  10238.         # handle option to indent non-blocks of the form );  };  ];
  10239.         if ( !$block_type_to_go[$ibeg] ) {
  10240.             if (   $rOpts->{'indent-closing-paren'}
  10241.                 && $is_semicolon_terminated
  10242.                 && $i_terminal == $ibeg + 1 )
  10243.             {
  10244.                 $adjust_indentation = -1;
  10245.             }
  10246.         }
  10247.  
  10248.         # handle option to indent blocks
  10249.         else {
  10250.             if (
  10251.                 $rOpts->{'indent-closing-brace'}
  10252.                 && (
  10253.                     $i_terminal == $ibeg    #  isolated terminal '}'
  10254.                     || $is_semicolon_terminated
  10255.                 )
  10256.               )                             #  } xxxx ;
  10257.             {
  10258.                 $adjust_indentation = -1;
  10259.             }
  10260.         }
  10261.  
  10262.     }
  10263.  
  10264.     # if at ');', '};', '>;', and '];' of a terminal qw quote
  10265.     elsif ( $$rpatterns[0] =~ /^qb*;$/ && $$rfields[0] =~ /^[\)\}\]\>];$/ ) {
  10266.         if ( !$rOpts->{'indent-closing-paren'} ) {
  10267.             $adjust_indentation = 1;
  10268.         }
  10269.         else {
  10270.             $adjust_indentation = -1;
  10271.         }
  10272.     }
  10273.  
  10274.     # Handle variation in indentation styles...
  10275.     # Select the indentation object to define leading
  10276.     # whitespace.  If we are outdenting something like '} } );'
  10277.     # then we want to use one level below the last token
  10278.     # ($i_terminal) in order to get it to fully outdent through
  10279.     # all levels.
  10280.     my $indentation;
  10281.     my $lev;
  10282.     my $level_end = $levels_to_go[$iend];
  10283.  
  10284.     if ( $adjust_indentation == 0 ) {
  10285.         $indentation = $leading_spaces_to_go[$ibeg];
  10286.         $lev         = $levels_to_go[$ibeg];
  10287.     }
  10288.     elsif ( $adjust_indentation == 1 ) {
  10289.         $indentation = $reduced_spaces_to_go[$i_terminal];
  10290.         $lev         = $levels_to_go[$i_terminal];
  10291.     }
  10292.     else {
  10293.  
  10294.         # There are two ways to handle -icb and -icp...
  10295.         # One way is to use the indentation of the previous line:
  10296.         # $indentation = $last_indentation_written;
  10297.  
  10298.         # The other way is to use the indentation that the previous line
  10299.         # would have had if it hadn't been adjusted:
  10300.         $indentation = $last_unadjusted_indentation;
  10301.  
  10302.         # Current method: use the minimum of the two. This avoids inconsistent
  10303.         # indentation.
  10304.         if ( get_SPACES($last_indentation_written) < get_SPACES($indentation) )
  10305.         {
  10306.             $indentation = $last_indentation_written;
  10307.         }
  10308.  
  10309.         # use previous indentation but use own level
  10310.         # to cause list to be flushed properly
  10311.         $lev = $levels_to_go[$ibeg];
  10312.     }
  10313.  
  10314.     # remember indentation except for multi-line quotes, which get
  10315.     # no indentation
  10316.     unless ( $types_to_go[$ibeg] eq 'Q' && $lev == 0 ) {
  10317.         $last_indentation_written    = $indentation;
  10318.         $last_unadjusted_indentation = $leading_spaces_to_go[$ibeg];
  10319.     }
  10320.  
  10321.     # be sure lines with leading closing tokens are not outdented more
  10322.     # than the line which contained the corresponding opening token.
  10323.     my $is_isolated_block_brace =
  10324.       ( $iend == $ibeg ) && $block_type_to_go[$ibeg];
  10325.     if ( !$is_isolated_block_brace && defined($opening_indentation) ) {
  10326.         if ( get_SPACES($opening_indentation) > get_SPACES($indentation) ) {
  10327.             $indentation = $opening_indentation;
  10328.         }
  10329.     }
  10330.  
  10331.     # remember the indentation of each line of this batch
  10332.     push @{$rindentation_list}, $indentation;
  10333.  
  10334.     # outdent lines with certain leading tokens...
  10335.     if (
  10336.  
  10337.         # must be first word of this batch
  10338.         $ibeg == 0
  10339.  
  10340.         # and ...
  10341.         && (
  10342.  
  10343.             # certain leading keywords if requested
  10344.             (
  10345.                    $rOpts->{'outdent-keywords'}
  10346.                 && $types_to_go[$ibeg] eq 'k'
  10347.                 && $outdent_keyword{ $tokens_to_go[$ibeg] }
  10348.             )
  10349.  
  10350.             # or labels if requested
  10351.             || ( $rOpts->{'outdent-labels'} && $types_to_go[$ibeg] eq 'J' )
  10352.  
  10353.             # or static block comments if requested
  10354.             || (   $types_to_go[$ibeg] eq '#'
  10355.                 && $rOpts->{'outdent-static-block-comments'}
  10356.                 && $tokens_to_go[$ibeg] =~ /$static_block_comment_pattern/o
  10357.                 && $rOpts->{'static-block-comments'} )
  10358.         )
  10359.       )
  10360.  
  10361.     {
  10362.         my $space_count = leading_spaces_to_go($ibeg);
  10363.         if ( $space_count > 0 ) {
  10364.             $space_count -= $rOpts_continuation_indentation;
  10365.             $is_outdented_line = 1;
  10366.             if ( $space_count < 0 ) { $space_count = 0 }
  10367.  
  10368.             # do not promote a spaced static block comment to non-spaced;
  10369.             # this is not normally necessary but could be for some
  10370.             # unusual user inputs (such as -ci = -i)
  10371.             if ( $types_to_go[$ibeg] eq '#' && $space_count == 0 ) {
  10372.                 $space_count = 1;
  10373.             }
  10374.  
  10375.             if ($rOpts_line_up_parentheses) {
  10376.                 $indentation =
  10377.                   new_lp_indentation_item( $space_count, $lev, 0, 0, 0 );
  10378.             }
  10379.             else {
  10380.                 $indentation = $space_count;
  10381.             }
  10382.         }
  10383.     }
  10384.  
  10385.     return ( $indentation, $lev, $level_end, $is_semicolon_terminated,
  10386.         $is_outdented_line );
  10387. }
  10388.  
  10389. sub set_vertical_tightness_flags {
  10390.  
  10391.     my ( $n, $n_last_line, $ibeg, $iend, $ri_first, $ri_last ) = @_;
  10392.  
  10393.     # Define vertical tightness controls for the nth line of a batch.
  10394.     # We create an array of parameters which tell the vertical aligner
  10395.     # if we should combine this line with the next line to achieve the
  10396.     # desired vertical tightness.  The array of parameters contains:
  10397.     #
  10398.     #   [0] type: 1=is opening tok 2=is closing tok  3=is opening block brace
  10399.     #   [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
  10400.     #             if closing: spaces of padding to use
  10401.     #   [2] sequence number of container
  10402.     #   [3] valid flag: do not append if this flag is false. Will be
  10403.     #       true if appropriate -vt flag is set.  Otherwise, Will be
  10404.     #       made true only for 2 line container in parens with -lp
  10405.     #
  10406.     # These flags are used by sub set_leading_whitespace in
  10407.     # the vertical aligner
  10408.  
  10409.     my $rvertical_tightness_flags;
  10410.  
  10411.     # For non-BLOCK tokens, we will need to examine the next line
  10412.     # too, so we won't consider the last line.
  10413.     if ( $n < $n_last_line ) {
  10414.  
  10415.         # see if last token is an opening token...not a BLOCK...
  10416.         my $ibeg_next = $$ri_first[ $n + 1 ];
  10417.         my $token_end = $tokens_to_go[$iend];
  10418.         my $iend_next = $$ri_last[ $n + 1 ];
  10419.         if (
  10420.                $type_sequence_to_go[$iend]
  10421.             && !$block_type_to_go[$iend]
  10422.             && $is_opening_token{$token_end}
  10423.             && (
  10424.                 $opening_vertical_tightness{$token_end} > 0
  10425.  
  10426.                 # allow 2-line method call to be closed up
  10427.                 || (   $rOpts_line_up_parentheses
  10428.                     && $token_end eq '('
  10429.                     && $iend > $ibeg
  10430.                     && $types_to_go[ $iend - 1 ] ne 'b' )
  10431.             )
  10432.           )
  10433.         {
  10434.  
  10435.             # avoid multiple jumps in nesting depth in one line if
  10436.             # requested
  10437.             my $ovt       = $opening_vertical_tightness{$token_end};
  10438.             my $iend_next = $$ri_last[ $n + 1 ];
  10439.             unless (
  10440.                 $ovt < 2
  10441.                 && ( $nesting_depth_to_go[ $iend_next + 1 ] !=
  10442.                     $nesting_depth_to_go[$ibeg_next] )
  10443.               )
  10444.             {
  10445.  
  10446.                 # If -vt flag has not been set, mark this as invalid
  10447.                 # and aligner will validate it if it sees the closing paren
  10448.                 # within 2 lines.
  10449.                 my $valid_flag = $ovt;
  10450.                 @{$rvertical_tightness_flags} =
  10451.                   ( 1, $ovt, $type_sequence_to_go[$iend], $valid_flag );
  10452.             }
  10453.         }
  10454.  
  10455.         # see if first token of next line is a closing token...
  10456.         # ..and be sure this line does not have a side comment
  10457.         my $token_next = $tokens_to_go[$ibeg_next];
  10458.         if (   $type_sequence_to_go[$ibeg_next]
  10459.             && !$block_type_to_go[$ibeg_next]
  10460.             && $is_closing_token{$token_next}
  10461.             && $types_to_go[$iend] !~ '#' )    # for safety, shouldn't happen!
  10462.         {
  10463.             my $ovt = $opening_vertical_tightness{$token_next};
  10464.             my $cvt = $closing_vertical_tightness{$token_next};
  10465.             if (
  10466.  
  10467.                 # never append a trailing line like   )->pack(
  10468.                 # because it will throw off later alignment
  10469.                 (
  10470.                     $nesting_depth_to_go[$ibeg_next] ==
  10471.                     $nesting_depth_to_go[ $iend_next + 1 ] + 1
  10472.                 )
  10473.                 && (
  10474.                     $cvt == 2
  10475.                     || (
  10476.                         $container_environment_to_go[$ibeg_next] ne 'LIST'
  10477.                         && (
  10478.                             $cvt == 1
  10479.  
  10480.                             # allow closing up 2-line method calls
  10481.                             || (   $rOpts_line_up_parentheses
  10482.                                 && $token_next eq ')' )
  10483.                         )
  10484.                     )
  10485.                 )
  10486.               )
  10487.             {
  10488.  
  10489.                 # decide which trailing closing tokens to append..
  10490.                 my $ok = 0;
  10491.                 if ( $cvt == 2 || $iend_next == $ibeg_next ) { $ok = 1 }
  10492.                 else {
  10493.                     my $str =
  10494.                       join ( '',
  10495.                         @types_to_go[ $ibeg_next + 1 .. $ibeg_next + 2 ] );
  10496.  
  10497.                     # append closing token if followed by comment or ';'
  10498.                     if ( $str =~ /^b?[#;]/ ) { $ok = 1 }
  10499.                 }
  10500.  
  10501.                 if ($ok) {
  10502.                     my $valid_flag = $cvt;
  10503.                     @{$rvertical_tightness_flags} = (
  10504.                         2,
  10505.                         $tightness{$token_next} == 2 ? 0 : 1,
  10506.                         $type_sequence_to_go[$ibeg_next], $valid_flag,
  10507.                     );
  10508.                 }
  10509.             }
  10510.         }
  10511.     }
  10512.  
  10513.     # Check for a last line with isolated opening BLOCK curly
  10514.     elsif ($rOpts_block_brace_vertical_tightness
  10515.         && $ibeg               eq $iend
  10516.         && $types_to_go[$iend] eq '{'
  10517.         && $block_type_to_go[$iend] =~
  10518.         /$block_brace_vertical_tightness_pattern/o )
  10519.     {
  10520.         @{$rvertical_tightness_flags} =
  10521.           ( 3, $rOpts_block_brace_vertical_tightness, 0, 1 );
  10522.     }
  10523.  
  10524.     return $rvertical_tightness_flags;
  10525. }
  10526.  
  10527. {
  10528.     my %is_vertical_alignment_type;
  10529.     my %is_vertical_alignment_keyword;
  10530.  
  10531.     BEGIN {
  10532.         @_ = qw#{ ? : => = += -= =~ *= /= && || ||= #;
  10533.         @is_vertical_alignment_type{@_} = (1) x scalar(@_);
  10534.  
  10535.         @_ = qw(if unless and or eq ne);
  10536.         @is_vertical_alignment_keyword{@_} = (1) x scalar(@_);
  10537.     }
  10538.  
  10539.     sub set_vertical_alignment_markers {
  10540.  
  10541.         # Look at the tokens in this output batch and define the array
  10542.         # 'matching_token_to_go' which marks tokens at which we would
  10543.         # accept vertical alignment.
  10544.  
  10545.         # nothing to do if we aren't allowed to change whitespace
  10546.         if ( !$rOpts_add_whitespace ) {
  10547.             for my $i ( 0 .. $max_index_to_go ) {
  10548.                 $matching_token_to_go[$i] = '';
  10549.             }
  10550.             return;
  10551.         }
  10552.  
  10553.         my ( $ri_first, $ri_last ) = @_;
  10554.  
  10555.         # look at each line of this batch..
  10556.         my $last_vertical_alignment_before_index;
  10557.         my $vert_last_nonblank_type;
  10558.         my $vert_last_nonblank_block_type;
  10559.         my $max_line = @$ri_first - 1;
  10560.         my ( $i, $type, $token, $block_type, $last_nonblank_token,
  10561.             $alignment_type );
  10562.         my ( $ibeg, $iend, $line );
  10563.         foreach $line ( 0 .. $max_line ) {
  10564.             $ibeg                                 = $$ri_first[$line];
  10565.             $iend                                 = $$ri_last[$line];
  10566.             $last_vertical_alignment_before_index = -1;
  10567.             $vert_last_nonblank_type              = '';
  10568.             $vert_last_nonblank_block_type        = '';
  10569.  
  10570.             # look at each token in this output line..
  10571.             foreach $i ( $ibeg .. $iend ) {
  10572.                 $alignment_type = '';
  10573.                 $type           = $types_to_go[$i];
  10574.                 $block_type     = $block_type_to_go[$i];
  10575.                 $token          = $tokens_to_go[$i];
  10576.  
  10577.                 # check for flag indicating that we should not align
  10578.                 # this token
  10579.                 if ( $matching_token_to_go[$i] ) {
  10580.                     $matching_token_to_go[$i] = '';
  10581.                     next;
  10582.                 }
  10583.  
  10584.                 #--------------------------------------------------------
  10585.                 # First see if we want to align BEFORE this token
  10586.                 #--------------------------------------------------------
  10587.  
  10588.                 # The first possible token that we can align before
  10589.                 # is index 2 because: 1) it doesn't normally make sense to
  10590.                 # align before the first token and 2) the second
  10591.                 # token must be a blank if we are to align before
  10592.                 # the third
  10593.                 if ( $i < $ibeg + 2 ) {
  10594.                 }
  10595.  
  10596.                 # must follow a blank token
  10597.                 elsif ( $types_to_go[ $i - 1 ] ne 'b' ) {
  10598.                 }
  10599.  
  10600.                 # align a side comment --
  10601.                 elsif ( $type eq '#' ) {
  10602.  
  10603.                     unless (
  10604.  
  10605.                         # it is a static side comment
  10606.                         (
  10607.                                $rOpts->{'static-side-comments'}
  10608.                             && $token =~ /$static_side_comment_pattern/o
  10609.                         )
  10610.  
  10611.                         # or a closing side comment
  10612.                         || (   $vert_last_nonblank_block_type
  10613.                             && $token =~
  10614.                             /$closing_side_comment_prefix_pattern/o )
  10615.                       )
  10616.                     {
  10617.                         $alignment_type = $type;
  10618.                     }    ## Example of a static side comment
  10619.                 }
  10620.  
  10621.                 # otherwise, do not align two in a row to create a
  10622.                 # blank field
  10623.                 elsif ( $last_vertical_alignment_before_index == $i - 2 ) {
  10624.                 }
  10625.  
  10626.                 # align before one of these keywords
  10627.                 # (within a line, since $i>1)
  10628.                 elsif ( $type eq 'k' ) {
  10629.  
  10630.                     #  /^(if|unless|and|or|eq|ne)$/
  10631.                     if ( $is_vertical_alignment_keyword{$token} ) {
  10632.                         $alignment_type = $token;
  10633.                     }
  10634.                 }
  10635.  
  10636.              # We have to be very careful about alignment before opening parens.
  10637.              # It is ok to line up sequences like this:
  10638.              #    if    ( $something eq "simple" )  { &handle_simple }
  10639.              #    elsif ( $something eq "hard" )    { &handle_hard }
  10640.                 elsif ( $type eq '(' ) {
  10641.                     if ( ( $i == $ibeg + 2 )
  10642.                         && $tokens_to_go[$ibeg] =~ /^(if|elsif)/ )
  10643.                     {
  10644.                         $alignment_type = $type;
  10645.                     }
  10646.                 }
  10647.  
  10648.                 # align before one of these types..
  10649.                 # Note: add '.' after new vertical aligner is operational
  10650.                 elsif ( $is_vertical_alignment_type{$type} ) {
  10651.                     $alignment_type = $token;
  10652.  
  10653.                     # be sure the alignment tokens are unique
  10654.                     # This didn't work well: reason not determined
  10655.                     # if ($token ne $type) {$alignment_type .= $type}
  10656.                 }
  10657.  
  10658.               # NOTE: This is deactivated until the new vertical aligner
  10659.               # is finished because it causes the previous if/elsif alignment
  10660.               # to fail
  10661.               #elsif ( $type eq '}' && $token eq '}' && $block_type_to_go[$i]) {
  10662.               #    $alignment_type = $type;
  10663.               #}
  10664.  
  10665.                 if ($alignment_type) {
  10666.                     $last_vertical_alignment_before_index = $i;
  10667.                 }
  10668.  
  10669.                 #--------------------------------------------------------
  10670.                 # Next see if we want to align AFTER the previous nonblank
  10671.                 #--------------------------------------------------------
  10672.  
  10673.                 # We want to line up ',' and interior ';' tokens, with the added
  10674.                 # space AFTER these tokens.  (Note: interior ';' is included
  10675.                 # because it may occur in short blocks).
  10676.                 if (
  10677.  
  10678.                     # we haven't already set it
  10679.                     !$alignment_type
  10680.  
  10681.                     # and its not the first token of the line
  10682.                     && ( $i > $ibeg )
  10683.  
  10684.                     # and it follows a blank
  10685.                     && $types_to_go[ $i - 1 ] eq 'b'
  10686.  
  10687.                     # and previous token IS one of these:
  10688.                     && ( $vert_last_nonblank_type =~ /^[\,\;]$/ )
  10689.  
  10690.                     # and it's NOT one of these
  10691.                     && ( $type !~ /^[b\#\)\]\}]$/ )
  10692.  
  10693.                     # then go ahead and align
  10694.                   )
  10695.  
  10696.                 {
  10697.                     $alignment_type = $vert_last_nonblank_type;
  10698.                 }
  10699.  
  10700.                 #--------------------------------------------------------
  10701.                 # then store the value
  10702.                 #--------------------------------------------------------
  10703.                 $matching_token_to_go[$i] = $alignment_type;
  10704.                 if ( $type ne 'b' ) {
  10705.                     $vert_last_nonblank_type       = $type;
  10706.                     $vert_last_nonblank_block_type = $block_type;
  10707.                 }
  10708.             }
  10709.         }
  10710.     }
  10711. }
  10712.  
  10713. sub terminal_type {
  10714.  
  10715.     #    returns type of last token on this line (terminal token), as follows:
  10716.     #    returns # for a full-line comment
  10717.     #    returns ' ' for a blank line
  10718.     #    otherwise returns final token type
  10719.  
  10720.     my ( $rtype, $rblock_type, $ibeg, $iend ) = @_;
  10721.  
  10722.     # check for full-line comment..
  10723.     if ( $$rtype[$ibeg] eq '#' ) {
  10724.         return wantarray ? ( $$rtype[$ibeg], $ibeg ) : $$rtype[$ibeg];
  10725.     }
  10726.     else {
  10727.  
  10728.         # start at end and walk bakwards..
  10729.         for ( my $i = $iend ; $i >= $ibeg ; $i-- ) {
  10730.  
  10731.             # skip past any side comment and blanks
  10732.             next if ( $$rtype[$i] eq 'b' );
  10733.             next if ( $$rtype[$i] eq '#' );
  10734.  
  10735.             # found it..make sure it is a BLOCK termination,
  10736.             # but hide a terminal } after sort/grep/map because it is not
  10737.             # necessarily the end of the line.  (terminal.t)
  10738.             my $terminal_type = $$rtype[$i];
  10739.             if (
  10740.                 $terminal_type eq '}'
  10741.                 && ( !$$rblock_type[$i]
  10742.                     || ( $$rblock_type[$i] =~ /^(sort|grep|map|do|eval)$/ ) )
  10743.               )
  10744.             {
  10745.                 $terminal_type = 'b';
  10746.             }
  10747.             return wantarray ? ( $terminal_type, $i ) : $terminal_type;
  10748.         }
  10749.  
  10750.         # empty line
  10751.         return wantarray ? ( ' ', $ibeg ) : ' ';
  10752.     }
  10753. }
  10754.  
  10755. sub set_bond_strengths {
  10756.  
  10757.     BEGIN {
  10758.  
  10759.         ###############################################################
  10760.         # NOTE: NO_BREAK's set here are HINTS which may not be honored;
  10761.         # essential NO_BREAKS's must be enforced in section 2, below.
  10762.         ###############################################################
  10763.  
  10764.         # adding NEW_TOKENS: add a left and right bond strength by
  10765.         # mimmicking what is done for an existing token type.  You
  10766.         # can skip this step at first and take the default, then
  10767.         # tweak later to get desired results.
  10768.  
  10769.         # The bond strengths should roughly follow precenence order where
  10770.         # possible.  If you make changes, please check the results very
  10771.         # carefully on a variety of scripts.
  10772.  
  10773.         # no break around possible filehandle
  10774.         $left_bond_strength{'Z'}  = NO_BREAK;
  10775.         $right_bond_strength{'Z'} = NO_BREAK;
  10776.  
  10777.         # never put a bare word on a new line:
  10778.         # example print (STDERR, "bla"); will fail with break after (
  10779.         $left_bond_strength{'w'} = NO_BREAK;
  10780.  
  10781.         # blanks always have infinite strength to force breaks after real tokens
  10782.         $right_bond_strength{'b'} = NO_BREAK;
  10783.  
  10784.         # try not to break on exponentation
  10785.         @_                       = qw" ** .. ... <=> ";
  10786.         @left_bond_strength{@_}  = (STRONG) x scalar(@_);
  10787.         @right_bond_strength{@_} = (STRONG) x scalar(@_);
  10788.  
  10789.         # The comma-arrow has very low precedence but not a good break point
  10790.         $left_bond_strength{'=>'}  = NO_BREAK;
  10791.         $right_bond_strength{'=>'} = NOMINAL;
  10792.  
  10793.         # ok to break after label
  10794.         $left_bond_strength{'J'}  = NO_BREAK;
  10795.         $right_bond_strength{'J'} = NOMINAL;
  10796.         $left_bond_strength{'j'}  = STRONG;
  10797.         $right_bond_strength{'j'} = STRONG;
  10798.         $left_bond_strength{'A'}  = STRONG;
  10799.         $right_bond_strength{'A'} = STRONG;
  10800.  
  10801.         $left_bond_strength{'->'}  = STRONG;
  10802.         $right_bond_strength{'->'} = VERY_STRONG;
  10803.  
  10804.         # breaking AFTER these is just ok:
  10805.         @_                       = qw" % + - * / x  ";
  10806.         @left_bond_strength{@_}  = (STRONG) x scalar(@_);
  10807.         @right_bond_strength{@_} = (NOMINAL) x scalar(@_);
  10808.  
  10809.         # breaking BEFORE these is just ok:
  10810.         @_                       = qw" >> << ";
  10811.         @right_bond_strength{@_} = (STRONG) x scalar(@_);
  10812.         @left_bond_strength{@_}  = (NOMINAL) x scalar(@_);
  10813.  
  10814.         # I prefer breaking before the string concatenation operator
  10815.         # because it can be hard to see at the end of a line
  10816.         # swap these to break after a '.'
  10817.         # this could be a future option
  10818.         $right_bond_strength{'.'} = STRONG;
  10819.         $left_bond_strength{'.'}  = 0.9 * NOMINAL + 0.1 * WEAK;
  10820.  
  10821.         @_                       = qw"} ] ) ";
  10822.         @left_bond_strength{@_}  = (STRONG) x scalar(@_);
  10823.         @right_bond_strength{@_} = (NOMINAL) x scalar(@_);
  10824.  
  10825.         # make these a little weaker than nominal so that they get
  10826.         # favored for end-of-line characters
  10827.         @_                       = qw"!= == =~ !~";
  10828.         @left_bond_strength{@_}  = (STRONG) x scalar(@_);
  10829.         @right_bond_strength{@_} = ( 0.9 * NOMINAL + 0.1 * WEAK ) x scalar(@_);
  10830.  
  10831.         # break AFTER these
  10832.         @_                       = qw" < >  | & >= <=";
  10833.         @left_bond_strength{@_}  = (VERY_STRONG) x scalar(@_);
  10834.         @right_bond_strength{@_} = ( 0.8 * NOMINAL + 0.2 * WEAK ) x scalar(@_);
  10835.  
  10836.         # breaking either before or after a quote is ok
  10837.         # but bias for breaking before a quote
  10838.         $left_bond_strength{'Q'}  = NOMINAL;
  10839.         $right_bond_strength{'Q'} = NOMINAL + 0.02;
  10840.         $left_bond_strength{'q'}  = NOMINAL;
  10841.         $right_bond_strength{'q'} = NOMINAL;
  10842.  
  10843.         # starting a line with a keyword is usually ok
  10844.         $left_bond_strength{'k'} = NOMINAL;
  10845.  
  10846.         # we usually want to bond a keyword strongly to what immediately
  10847.         # follows, rather than leaving it stranded at the end of a line
  10848.         $right_bond_strength{'k'} = STRONG;
  10849.  
  10850.         $left_bond_strength{'G'}  = NOMINAL;
  10851.         $right_bond_strength{'G'} = STRONG;
  10852.  
  10853.         # it is very good to break AFTER various assignment operators
  10854.         @_ = qw(
  10855.           = **= += *= &= <<= &&=
  10856.           -= /= |= >>= ||=
  10857.           .= %= ^=
  10858.           x=
  10859.         );
  10860.         @left_bond_strength{@_}  = (STRONG) x scalar(@_);
  10861.         @right_bond_strength{@_} =
  10862.           ( 0.4 * WEAK + 0.6 * VERY_WEAK ) x scalar(@_);
  10863.  
  10864.         # break BEFORE '&&' and '||'
  10865.         # set strength of '||' to same as '=' so that chains like
  10866.         # $a = $b || $c || $d   will break before the first '||'
  10867.         $right_bond_strength{'||'} = NOMINAL;
  10868.         $left_bond_strength{'||'}  = $right_bond_strength{'='};
  10869.  
  10870.         # set strength of && a little higher than ||
  10871.         $right_bond_strength{'&&'} = NOMINAL;
  10872.         $left_bond_strength{'&&'}  = $left_bond_strength{'||'} + 0.1;
  10873.  
  10874.         $left_bond_strength{';'}  = VERY_STRONG;
  10875.         $right_bond_strength{';'} = VERY_WEAK;
  10876.         $left_bond_strength{'f'}  = VERY_STRONG;
  10877.  
  10878.         # make right strength of for ';' a little less than '='
  10879.         # to make for contents break after the ';' to avoid this:
  10880.         #   for ( $j = $number_of_fields - 1 ; $j < $item_count ; $j +=
  10881.         #     $number_of_fields )
  10882.         # and make it weaker than ',' and 'and' too
  10883.         $right_bond_strength{'f'} = VERY_WEAK - 0.03;
  10884.  
  10885.         # The strengths of ?/: should be somewhere between
  10886.         # an '=' and a quote (NOMINAL),
  10887.         # make strength of ':' slightly less than '?' to help
  10888.         # break long chains of ? : after the colons
  10889.         $left_bond_strength{':'}  = 0.4 * WEAK + 0.6 * NOMINAL;
  10890.         $right_bond_strength{':'} = NO_BREAK;
  10891.         $left_bond_strength{'?'}  = $left_bond_strength{':'} + 0.01;
  10892.         $right_bond_strength{'?'} = NO_BREAK;
  10893.  
  10894.         $left_bond_strength{','}  = VERY_STRONG;
  10895.         $right_bond_strength{','} = VERY_WEAK;
  10896.     }
  10897.  
  10898.     # patch-its always ok to break at end of line
  10899.     $nobreak_to_go[$max_index_to_go] = 0;
  10900.  
  10901.     # adding a small 'bias' to strengths is a simple way to make a line
  10902.     # break at the first of a sequence of identical terms.  For example,
  10903.     # to force long string of conditional operators to break with
  10904.     # each line ending in a ':', we can add a small number to the bond
  10905.     # strength of each ':'
  10906.     my $colon_bias = 0;
  10907.     my $amp_bias   = 0;
  10908.     my $bar_bias   = 0;
  10909.     my $and_bias   = 0;
  10910.     my $or_bias    = 0;
  10911.     my $dot_bias   = 0;
  10912.     my $f_bias     = 0;
  10913.     my $code_bias  = -.01;
  10914.     my $type       = 'b';
  10915.     my $token      = ' ';
  10916.     my $last_type;
  10917.     my $last_nonblank_type  = $type;
  10918.     my $last_nonblank_token = $token;
  10919.     my $delta_bias          = 0.0001;
  10920.     my $list_str            = $left_bond_strength{'?'};
  10921.  
  10922.     my ( $block_type, $i_next, $i_next_nonblank, $next_nonblank_token,
  10923.         $next_nonblank_type, $next_token, $next_type, $total_nesting_depth, );
  10924.  
  10925.     # preliminary loop to compute bond strengths
  10926.     for ( my $i = 0 ; $i <= $max_index_to_go ; $i++ ) {
  10927.         $last_type = $type;
  10928.         if ( $type ne 'b' ) {
  10929.             $last_nonblank_type  = $type;
  10930.             $last_nonblank_token = $token;
  10931.         }
  10932.         $type = $types_to_go[$i];
  10933.  
  10934.         # strength on both sides of a blank is the same
  10935.         if ( $type eq 'b' && $last_type ne 'b' ) {
  10936.             $bond_strength_to_go[$i] = $bond_strength_to_go[ $i - 1 ];
  10937.             next;
  10938.         }
  10939.  
  10940.         $token               = $tokens_to_go[$i];
  10941.         $block_type          = $block_type_to_go[$i];
  10942.         $i_next              = $i + 1;
  10943.         $next_type           = $types_to_go[$i_next];
  10944.         $next_token          = $tokens_to_go[$i_next];
  10945.         $total_nesting_depth = $nesting_depth_to_go[$i_next];
  10946.         $i_next_nonblank     = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
  10947.         $next_nonblank_type  = $types_to_go[$i_next_nonblank];
  10948.         $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
  10949.  
  10950.         # Some token chemistry...  The decision about where to break a
  10951.         # line depends upon a "bond strength" between tokens.  The LOWER
  10952.         # the bond strength, the MORE likely a break.  The strength
  10953.         # values are based on trial-and-error, and need to be tweaked
  10954.         # occasionally to get desired results.  Things to keep in mind
  10955.         # are:
  10956.         #   1. relative strengths are important.  small differences
  10957.         #      in strengths can make big formatting differences.
  10958.         #   2. each indentation level adds one unit of bond strength
  10959.         #   3. a value of NO_BREAK makes an unbreakable bond
  10960.         #   4. a value of VERY_WEAK is the strength of a ','
  10961.         #   5. values below NOMINAL are considered ok break points
  10962.         #   6. values above NOMINAL are considered poor break points
  10963.         # We are computing the strength of the bond between the current
  10964.         # token and the NEXT token.
  10965.         my $bond_str = VERY_STRONG;    # a default, high strength
  10966.  
  10967.         #---------------------------------------------------------------
  10968.         # section 1:
  10969.         # use minimum of left and right bond strengths if defined;
  10970.         # digraphs and trigraphs like to break on their left
  10971.         #---------------------------------------------------------------
  10972.         my $bsr = $right_bond_strength{$type};
  10973.  
  10974.         if ( !defined($bsr) ) {
  10975.  
  10976.             if ( $is_digraph{$type} || $is_trigraph{$type} ) {
  10977.                 $bsr = STRONG;
  10978.             }
  10979.             else {
  10980.                 $bsr = VERY_STRONG;
  10981.             }
  10982.         }
  10983.  
  10984.         if ( $token eq 'and' or $token eq 'or' ) {
  10985.             $bsr = NOMINAL;
  10986.         }
  10987.         elsif ( $token eq 'ne' or $token eq 'eq' ) {
  10988.             $bsr = NOMINAL;
  10989.         }
  10990.         my $bsl = $left_bond_strength{$next_nonblank_type};
  10991.  
  10992.         # set terminal bond strength to the nominal value
  10993.         # this will cause good preceding breaks to be retained
  10994.         if ( $i_next_nonblank > $max_index_to_go ) {
  10995.             $bsl = NOMINAL;
  10996.         }
  10997.  
  10998.         if ( !defined($bsl) ) {
  10999.  
  11000.             if (   $is_digraph{$next_nonblank_type}
  11001.                 || $is_trigraph{$next_nonblank_type} )
  11002.             {
  11003.                 $bsl = WEAK;
  11004.             }
  11005.             else {
  11006.                 $bsl = VERY_STRONG;
  11007.             }
  11008.         }
  11009.  
  11010.         # make or, and slightly weaker than a ','
  11011.         if ( $next_nonblank_token eq 'or' ) {
  11012.             $bsl = VERY_WEAK - 0.02;
  11013.         }
  11014.         if ( $next_nonblank_token eq 'and' ) {
  11015.             $bsl = VERY_WEAK - 0.01;
  11016.         }
  11017.         elsif ( $next_nonblank_token eq 'ne' or $next_nonblank_token eq 'eq' ) {
  11018.             $bsl = NOMINAL;
  11019.         }
  11020.         elsif ( $next_nonblank_token =~ /^(lt|gt|le|ge)$/ ) {
  11021.             $bsl = 0.9 * NOMINAL + 0.1 * STRONG;
  11022.         }
  11023.  
  11024.         # Note: it might seem that we would want to keep a NO_BREAK if
  11025.         # either token has this value.  This didn't work, because in an
  11026.         # arrow list, it prevents the comma from separating from the
  11027.         # following bare word (which is probably quoted by its arrow).
  11028.         # So necessary NO_BREAK's have to be handled as special cases
  11029.         # in the final section.
  11030.         $bond_str = ( $bsr < $bsl ) ? $bsr : $bsl;
  11031.         my $bond_str_1 = $bond_str;
  11032.  
  11033.         #---------------------------------------------------------------
  11034.         # section 2:
  11035.         # special cases
  11036.         #---------------------------------------------------------------
  11037.  
  11038.         # allow long lines before final { in an if statement, as in:
  11039.         #    if (..........
  11040.         #      ..........)
  11041.         #    {
  11042.         #
  11043.         # Otherwise, the line before the { tends to be too short.
  11044.         if ( $type eq ')' ) {
  11045.             if ( $next_nonblank_type eq '{' ) {
  11046.                 $bond_str = VERY_WEAK + 0.03;
  11047.             }
  11048.         }
  11049.  
  11050.         elsif ( $type eq '(' ) {
  11051.             if ( $next_nonblank_type eq '{' ) {
  11052.                 $bond_str = NOMINAL;
  11053.             }
  11054.         }
  11055.  
  11056.         # break on something like '} (', but keep this stronger than a ','
  11057.         # example is in 'howe.pl'
  11058.         elsif ( $type eq 'R' or $type eq '}' ) {
  11059.             if ( $next_nonblank_type eq '(' ) {
  11060.                 $bond_str = 0.8 * VERY_WEAK + 0.2 * WEAK;
  11061.             }
  11062.         }
  11063.  
  11064.         #-----------------------------------------------------------------
  11065.         # adjust bond strength bias
  11066.         #-----------------------------------------------------------------
  11067.  
  11068.         elsif ( $type eq 'f' ) {
  11069.             $bond_str += $f_bias;
  11070.             $f_bias   += $delta_bias;
  11071.         }
  11072.  
  11073.         # in long ?: conditionals, bias toward just one set per line (colon.t)
  11074.         elsif ( $type eq ':' ) {
  11075.             if ( !$want_break_before{$type} ) {
  11076.                 $bond_str   += $colon_bias;
  11077.                 $colon_bias += $delta_bias;
  11078.             }
  11079.         }
  11080.  
  11081.         if (   $next_nonblank_type eq ':'
  11082.             && $want_break_before{$next_nonblank_type} )
  11083.         {
  11084.             $bond_str   += $colon_bias;
  11085.             $colon_bias += $delta_bias;
  11086.         }
  11087.  
  11088.         # if leading '.' is used, align all but 'short' quotes;
  11089.         # the idea is to not place something like "\n" on a single line.
  11090.         elsif ( $next_nonblank_type eq '.' ) {
  11091.             if ( $want_break_before{'.'} ) {
  11092.                 unless (
  11093.                     $last_nonblank_type eq '.'
  11094.                     && (
  11095.                         length($token) <=
  11096.                         $rOpts_short_concatenation_item_length )
  11097.                     && ( $token !~ /^[\)\]\}]$/ )
  11098.                   )
  11099.                 {
  11100.                     $dot_bias += $delta_bias;
  11101.                 }
  11102.                 $bond_str += $dot_bias;
  11103.             }
  11104.         }
  11105.         elsif ( $next_nonblank_type eq '&&' ) {
  11106.             $bond_str += $amp_bias;
  11107.             $amp_bias += $delta_bias;
  11108.         }
  11109.         elsif ( $next_nonblank_type eq '||' ) {
  11110.             $bond_str += $bar_bias;
  11111.             $bar_bias += $delta_bias;
  11112.         }
  11113.         elsif ( $next_nonblank_type eq 'k' ) {
  11114.  
  11115.             if ( $next_nonblank_token eq 'and' ) {
  11116.                 $bond_str += $and_bias;
  11117.                 $and_bias += $delta_bias;
  11118.             }
  11119.             elsif ( $next_nonblank_token eq 'or' ) {
  11120.                 $bond_str += $or_bias;
  11121.                 $or_bias  += $delta_bias;
  11122.             }
  11123.  
  11124.             # FIXME: needs more testing
  11125.             elsif ( $is_keyword_returning_list{$next_nonblank_token} ) {
  11126.                 $bond_str = $list_str if ( $bond_str > $list_str );
  11127.             }
  11128.         }
  11129.  
  11130.         # keep matrix and hash indices together
  11131.         # but make them a little below STRONG to allow breaking open
  11132.         # something like {'some-word'}{'some-very-long-word'} at the }{
  11133.         # (bracebrk.t)
  11134.         if (   ( $type eq ']' or $type eq 'R' )
  11135.             && ( $next_nonblank_type eq '[' or $next_nonblank_type eq 'L' ) )
  11136.         {
  11137.             $bond_str = 0.9 * STRONG + 0.1 * NOMINAL;
  11138.         }
  11139.  
  11140.         if ( $next_nonblank_type eq 'i' && $next_nonblank_token =~ /^->/ ) {
  11141.  
  11142.             # increase strength to the point where a break in the following
  11143.             # will be after the opening paren rather than at the arrow:
  11144.             #    $a->$b($c);
  11145.             if ( $type eq 'i' ) {
  11146.                 $bond_str = 1.45 * STRONG;
  11147.             }
  11148.  
  11149.             elsif ( $type =~ /^[\)\]\}R]$/ ) {
  11150.                 $bond_str = 0.1 * STRONG + 0.9 * NOMINAL;
  11151.             }
  11152.  
  11153.             # otherwise make strength before an '->' a little over a '+'
  11154.             else {
  11155.                 if ( $bond_str <= NOMINAL ) {
  11156.                     $bond_str = NOMINAL + 0.01;
  11157.                 }
  11158.             }
  11159.         }
  11160.  
  11161.         if ( $token eq ')' && $next_nonblank_token eq '[' ) {
  11162.             $bond_str = 0.2 * STRONG + 0.8 * NOMINAL;
  11163.         }
  11164.  
  11165.         # map1.t -- correct for a quirk in perl
  11166.         if (   $token eq '('
  11167.             && $next_nonblank_type eq 'i'
  11168.             && $last_nonblank_type eq 'k'
  11169.             && $is_sort_map_grep{$last_nonblank_token} )
  11170.  
  11171.           #     /^(sort|map|grep)$/ )
  11172.         {
  11173.             $bond_str = NO_BREAK;
  11174.         }
  11175.  
  11176.         # extrude.t: do not break before paren at:
  11177.         #    -l pid_filename(
  11178.         if ( $last_nonblank_type eq 'F' && $next_nonblank_token eq '(' ) {
  11179.             $bond_str = NO_BREAK;
  11180.         }
  11181.  
  11182.         # good to break after end of code blocks
  11183.         if ( $type eq '}' && $block_type ) {
  11184.  
  11185.             $bond_str = 0.5 * WEAK + 0.5 * VERY_WEAK + $code_bias;
  11186.             $code_bias += $delta_bias;
  11187.         }
  11188.  
  11189.         if ( $type eq 'k' ) {
  11190.  
  11191.             # allow certain control keywords to stand out
  11192.             if (   ( $next_nonblank_type eq 'k' )
  11193.                 && ( $token =~ /^(last|next|redo|return)$/ ) )
  11194.             {
  11195.                 $bond_str = 0.45 * WEAK + 0.55 * VERY_WEAK;
  11196.             }
  11197.  
  11198. # Don't break after keyword my.  This is a quick fix for a
  11199. # rare problem with perl. An example is this line from file
  11200. # Container.pm:
  11201. # foreach my $question( Debian::DebConf::ConfigDb::gettree( $this->{'question'} ) )
  11202.  
  11203.             if ( $token eq 'my' ) {
  11204.                 $bond_str = NO_BREAK;
  11205.             }
  11206.  
  11207.         }
  11208.  
  11209.         # good to break before 'if', 'unless', etc
  11210.         if ( $is_if_brace_follower{$next_nonblank_token} ) {
  11211.             $bond_str = VERY_WEAK;
  11212.         }
  11213.  
  11214.         if ( $next_nonblank_type eq 'k' ) {
  11215.  
  11216.             # keywords like 'unless' 'if' make good breaks
  11217.             if ( $is_do_follower{$next_nonblank_token} ) {
  11218.                 $bond_str = VERY_WEAK / 1.05;
  11219.             }
  11220.  
  11221.         }
  11222.  
  11223.         # try not to break before a comma-arrow
  11224.         elsif ( $next_nonblank_type eq '=>' ) {
  11225.             if ( $bond_str < STRONG ) { $bond_str = STRONG }
  11226.         }
  11227.  
  11228.         #----------------------------------------------------------------------
  11229.         # only set NO_BREAK's from here on
  11230.         #----------------------------------------------------------------------
  11231.         if ( $type eq 'C' or $type eq 'U' ) {
  11232.  
  11233.             # use strict requires that bare word and => not be separated
  11234.             if ( $next_nonblank_type eq '=>' ) {
  11235.                 $bond_str = NO_BREAK;
  11236.             }
  11237.  
  11238.         }
  11239.  
  11240.         # use strict requires that bare word within braces not start new line
  11241.         elsif ( $type eq 'L' ) {
  11242.  
  11243.             if ( $next_nonblank_type eq 'w' ) {
  11244.                 $bond_str = NO_BREAK;
  11245.             }
  11246.         }
  11247.  
  11248.         # in older version of perl, use strict can cause problems with
  11249.         # breaks before bare words following opening parens.  For example,
  11250.         # this will fail under older versions if a break is made between
  11251.         # '(' and 'MAIL':
  11252.         #  use strict;
  11253.         #  open( MAIL, "a long filename or command");
  11254.         #  close MAIL;
  11255.         elsif ( $type eq '{' ) {
  11256.  
  11257.             if ( $token eq '(' && $next_nonblank_type eq 'w' ) {
  11258.  
  11259.                 # but it's fine to break if the word is followed by a '=>'
  11260.                 # or if it is obviously a sub call
  11261.                 my $i_next_next_nonblank = $i_next_nonblank + 1;
  11262.                 my $next_next_type       = $types_to_go[$i_next_next_nonblank];
  11263.                 if (   $next_next_type eq 'b'
  11264.                     && $i_next_nonblank < $max_index_to_go )
  11265.                 {
  11266.                     $i_next_next_nonblank++;
  11267.                     $next_next_type = $types_to_go[$i_next_next_nonblank];
  11268.                 }
  11269.  
  11270.                 ##if ( $next_next_type ne '=>' ) {
  11271.                 # these are ok: '->xxx', '=>', '('
  11272.  
  11273.                 # We'll check for an old breakpoint and keep a leading
  11274.                 # bareword if it was that way in the input file.  Presumably
  11275.                 # it was ok that way.  For example, the following would remain
  11276.                 # unchanged:
  11277.                 #
  11278.                 # @months = (
  11279.                 #   January,   February, March,    April,
  11280.                 #   May,       June,     July,     August,
  11281.                 #   September, October,  November, December,
  11282.                 # );
  11283.                 #
  11284.                 # This should be sufficient:
  11285.                 if ( !$old_breakpoint_to_go[$i]
  11286.                     && ( $next_next_type eq ',' || $next_next_type eq '}' ) )
  11287.                 {
  11288.                     $bond_str = NO_BREAK;
  11289.                 }
  11290.             }
  11291.         }
  11292.  
  11293.         elsif ( $type eq 'w' ) {
  11294.  
  11295.             if ( $next_nonblank_type eq 'R' ) {
  11296.                 $bond_str = NO_BREAK;
  11297.             }
  11298.  
  11299.             # use strict requires that bare word and => not be separated
  11300.             if ( $next_nonblank_type eq '=>' ) {
  11301.                 $bond_str = NO_BREAK;
  11302.             }
  11303.         }
  11304.  
  11305.         # in fact, use strict hates bare words on any new line.  For example,
  11306.         # a break before the underscore here provokes the wrath of use strict:
  11307.         #    if ( -r $fn && ( -s _ || $AllowZeroFilesize)) {
  11308.         elsif ( $type eq 'F' ) {
  11309.             $bond_str = NO_BREAK;
  11310.         }
  11311.  
  11312.         # use strict does not allow separating type info from trailing { }
  11313.         # testfile is readmail.pl
  11314.         elsif ( $type eq 't' or $type eq 'i' ) {
  11315.  
  11316.             if ( $next_nonblank_type eq 'L' ) {
  11317.                 $bond_str = NO_BREAK;
  11318.             }
  11319.         }
  11320.  
  11321.         # Do not break between a possible filehandle and a ? or /
  11322.         # and do not introduce a break after it if there is no blank (extrude.t)
  11323.         elsif ( $type eq 'Z' ) {
  11324.  
  11325.             # dont break..
  11326.             if (
  11327.  
  11328.                 # if there is no blank and we do not want one. Examples:
  11329.                 #    print $x++    # do not break after $x
  11330.                 #    print HTML"HELLO"   # break ok after HTML
  11331.                 (
  11332.                        $next_type ne 'b'
  11333.                     && defined( $want_left_space{$next_type} )
  11334.                     && $want_left_space{$next_type} == WS_NO
  11335.                 )
  11336.  
  11337.                 # or we might be followed by the start of a quote
  11338.                 || $next_nonblank_type =~ /^[\/\?]$/
  11339.               )
  11340.             {
  11341.                 $bond_str = NO_BREAK;
  11342.             }
  11343.         }
  11344.  
  11345.         # Do not break before a possible file handle
  11346.         #if ( ( $type eq 'Z' ) || ( $next_nonblank_type eq 'Z' ) ) {
  11347.         if ( $next_nonblank_type eq 'Z' ) {
  11348.             $bond_str = NO_BREAK;
  11349.         }
  11350.  
  11351.         # patch to put cuddled elses back together when on multiple
  11352.         # lines, as in: } \n else \n { \n
  11353.         if ($rOpts_cuddled_else) {
  11354.  
  11355.             if (   ( $token eq 'else' ) && ( $next_nonblank_type eq '{' )
  11356.                 || ( $type eq '}' ) && ( $next_nonblank_token eq 'else' ) )
  11357.             {
  11358.                 $bond_str = NO_BREAK;
  11359.             }
  11360.         }
  11361.  
  11362.         # keep '}' together with ';'
  11363.         if ( ( $token eq '}' ) && ( $next_nonblank_type eq ';' ) ) {
  11364.             $bond_str = NO_BREAK;
  11365.         }
  11366.  
  11367.         # never break between sub name and opening paren
  11368.         if ( ( $type eq 'w' ) && ( $next_nonblank_token eq '(' ) ) {
  11369.             $bond_str = NO_BREAK;
  11370.         }
  11371.  
  11372.         #---------------------------------------------------------------
  11373.         # section 3:
  11374.         # now take nesting depth into account
  11375.         #---------------------------------------------------------------
  11376.         # final strength incorporates the bond strength and nesting depth
  11377.         my $strength;
  11378.  
  11379.         if ( defined($bond_str) && !$nobreak_to_go[$i] ) {
  11380.             if ( $total_nesting_depth > 0 ) {
  11381.                 $strength = $bond_str + $total_nesting_depth;
  11382.             }
  11383.             else {
  11384.                 $strength = $bond_str;
  11385.             }
  11386.         }
  11387.         else {
  11388.             $strength = NO_BREAK;
  11389.         }
  11390.  
  11391.         # always break after side comment
  11392.         if ( $type eq '#' ) { $strength = 0 }
  11393.  
  11394.         $bond_strength_to_go[$i] = $strength;
  11395.  
  11396.         FORMATTER_DEBUG_FLAG_BOND && do {
  11397.             my $str = substr( $token, 0, 15 );
  11398.             $str .= ' ' x ( 16 - length($str) );
  11399.             print
  11400. "BOND:  i=$i $str $type $next_nonblank_type depth=$total_nesting_depth strength=$bond_str_1 -> $bond_str -> $strength \n";
  11401.         };
  11402.     }
  11403. }
  11404.  
  11405. sub pad_array_to_go {
  11406.  
  11407.     # to simplify coding in scan_list and set_bond_strengths, it helps
  11408.     # to create some extra blank tokens at the end of the arrays
  11409.     $tokens_to_go[ $max_index_to_go + 1 ]        = '';
  11410.     $tokens_to_go[ $max_index_to_go + 2 ]        = '';
  11411.     $types_to_go[ $max_index_to_go + 1 ]         = 'b';
  11412.     $types_to_go[ $max_index_to_go + 2 ]         = 'b';
  11413.     $nesting_depth_to_go[ $max_index_to_go + 1 ] =
  11414.       $nesting_depth_to_go[$max_index_to_go];
  11415.  
  11416.     #    /^[R\}\)\]]$/
  11417.     if ( $is_closing_type{ $types_to_go[$max_index_to_go] } ) {
  11418.         if ( $nesting_depth_to_go[$max_index_to_go] <= 0 ) {
  11419.  
  11420.             # shouldn't happen:
  11421.             unless ( get_saw_brace_error() ) {
  11422.                 warning(
  11423. "Program bug in scan_list: hit nesting error which should have been caught\n"
  11424.                 );
  11425.                 report_definite_bug();
  11426.             }
  11427.         }
  11428.         else {
  11429.             $nesting_depth_to_go[ $max_index_to_go + 1 ] -= 1;
  11430.         }
  11431.     }
  11432.  
  11433.     #       /^[L\{\(\[]$/
  11434.     elsif ( $is_opening_type{ $types_to_go[$max_index_to_go] } ) {
  11435.         $nesting_depth_to_go[ $max_index_to_go + 1 ] += 1;
  11436.     }
  11437. }
  11438.  
  11439. {    # begin scan_list
  11440.  
  11441.     my (
  11442.         $block_type,                $current_depth,
  11443.         $depth,                     $i,
  11444.         $i_last_nonblank_token,     $last_colon_sequence_number,
  11445.         $last_nonblank_token,       $last_nonblank_type,
  11446.         $last_old_breakpoint_count, $minimum_depth,
  11447.         $next_nonblank_block_type,  $next_nonblank_token,
  11448.         $next_nonblank_type,        $old_breakpoint_count,
  11449.         $starting_breakpoint_count, $starting_depth,
  11450.         $token,                     $type,
  11451.         $type_sequence,
  11452.     );
  11453.  
  11454.     my (
  11455.         @breakpoint_stack,              @breakpoint_undo_stack,
  11456.         @comma_index,                   @container_type,
  11457.         @identifier_count_stack,        @index_before_arrow,
  11458.         @interrupted_list,              @item_count_stack,
  11459.         @last_comma_index,              @last_dot_index,
  11460.         @last_nonblank_type,            @old_breakpoint_count_stack,
  11461.         @opening_structure_index_stack, @rfor_semicolon_list,
  11462.         @has_old_logical_breakpoints,   @rand_or_list,
  11463.         @i_equals,
  11464.     );
  11465.  
  11466.     # routine to define essential variables when we go 'up' to
  11467.     # a new depth
  11468.     sub check_for_new_minimum_depth {
  11469.         my $depth = shift;
  11470.         if ( $depth < $minimum_depth ) {
  11471.  
  11472.             $minimum_depth = $depth;
  11473.  
  11474.             # these arrays need not retain values between calls
  11475.             $breakpoint_stack[$depth]              = $starting_breakpoint_count;
  11476.             $container_type[$depth]                = "";
  11477.             $identifier_count_stack[$depth]        = 0;
  11478.             $index_before_arrow[$depth]            = -1;
  11479.             $interrupted_list[$depth]              = 1;
  11480.             $item_count_stack[$depth]              = 0;
  11481.             $last_nonblank_type[$depth]            = "";
  11482.             $opening_structure_index_stack[$depth] = -1;
  11483.  
  11484.             $breakpoint_undo_stack[$depth]       = undef;
  11485.             $comma_index[$depth]                 = undef;
  11486.             $last_comma_index[$depth]            = undef;
  11487.             $last_dot_index[$depth]              = undef;
  11488.             $old_breakpoint_count_stack[$depth]  = undef;
  11489.             $has_old_logical_breakpoints[$depth] = 0;
  11490.             $rand_or_list[$depth]                = [];
  11491.             $rfor_semicolon_list[$depth]         = [];
  11492.             $i_equals[$depth]                    = -1;
  11493.  
  11494.             # these arrays must retain values between calls
  11495.             if ( !defined( $has_broken_sublist[$depth] ) ) {
  11496.                 $dont_align[$depth]         = 0;
  11497.                 $has_broken_sublist[$depth] = 0;
  11498.                 $want_comma_break[$depth]   = 0;
  11499.             }
  11500.         }
  11501.     }
  11502.  
  11503.     # routine to decide which commas to break at within a container;
  11504.     # returns:
  11505.     #   $bp_count = number of comma breakpoints set
  11506.     #   $do_not_break_apart = a flag indicating if container need not
  11507.     #     be broken open
  11508.     sub set_comma_breakpoints {
  11509.  
  11510.         my $dd                 = shift;
  11511.         my $bp_count           = 0;
  11512.         my $do_not_break_apart = 0;
  11513.         if ( $item_count_stack[$dd] && !$dont_align[$dd] ) {
  11514.  
  11515.             my $fbc = $forced_breakpoint_count;
  11516.  
  11517.             # always open comma lists not preceded by keywords,
  11518.             # barewords, identifiers (that is, anything that doesn't
  11519.             # look like a function call)
  11520.             my $must_break_open = $last_nonblank_type[$dd] !~ /^[kwiU]$/;
  11521.  
  11522.             set_comma_breakpoints_do(
  11523.                 $dd,
  11524.                 $opening_structure_index_stack[$dd],
  11525.                 $i,
  11526.                 $item_count_stack[$dd],
  11527.                 $identifier_count_stack[$dd],
  11528.                 $comma_index[$dd],
  11529.                 $next_nonblank_type,
  11530.                 $container_type[$dd],
  11531.                 $interrupted_list[$dd],
  11532.                 \$do_not_break_apart,
  11533.                 $must_break_open,
  11534.             );
  11535.             $bp_count = $forced_breakpoint_count - $fbc;
  11536.             $do_not_break_apart = 0 if $must_break_open;
  11537.         }
  11538.         return ( $bp_count, $do_not_break_apart );
  11539.     }
  11540.  
  11541.     my %is_logical_container;
  11542.  
  11543.     BEGIN {
  11544.         @_ = qw# if elsif unless while and or not && | || ? : ! #;
  11545.         @is_logical_container{@_} = (1) x scalar(@_);
  11546.     }
  11547.  
  11548.     sub set_for_semicolon_breakpoints {
  11549.         my $dd = shift;
  11550.         foreach ( @{ $rfor_semicolon_list[$dd] } ) {
  11551.             set_forced_breakpoint($_);
  11552.         }
  11553.     }
  11554.  
  11555.     sub set_logical_breakpoints {
  11556.         my $dd = shift;
  11557.         if (
  11558.                $item_count_stack[$dd] == 0
  11559.             && $is_logical_container{ $container_type[$dd] }
  11560.  
  11561.             # TESTING:
  11562.             || $has_old_logical_breakpoints[$dd]
  11563.           )
  11564.         {
  11565.  
  11566.             # Look for breaks in this order:
  11567.             # 0   1    2   3
  11568.             # or  and  ||  &&
  11569.             foreach my $i ( 0 .. 3 ) {
  11570.                 if ( $rand_or_list[$dd][$i] ) {
  11571.                     foreach ( @{ $rand_or_list[$dd][$i] } ) {
  11572.                         set_forced_breakpoint($_);
  11573.                     }
  11574.  
  11575.                     # break at any 'if' and 'unless' too
  11576.                     foreach ( @{ $rand_or_list[$dd][4] } ) {
  11577.                         set_forced_breakpoint($_);
  11578.                     }
  11579.                     $rand_or_list[$dd] = [];
  11580.                     last;
  11581.                 }
  11582.             }
  11583.         }
  11584.     }
  11585.  
  11586.     sub is_unbreakable_container {
  11587.  
  11588.         # never break a container of one of these types
  11589.         # because bad things can happen (map1.t)
  11590.         my $dd = shift;
  11591.  
  11592.         #/^(sort|map|grep)$/
  11593.         $is_sort_map_grep{ $container_type[$dd] };
  11594.     }
  11595.  
  11596.     sub scan_list {
  11597.  
  11598.         # This routine is responsible for setting line breaks for all lists,
  11599.         # so that hierarchical structure can be displayed and so that list
  11600.         # items can be vertically aligned.  The output of this routine is
  11601.         # stored in the array @forced_breakpoint_to_go, which is used to set
  11602.         # final breakpoints.
  11603.  
  11604.         $starting_depth = $nesting_depth_to_go[0];
  11605.  
  11606.         $block_type                 = ' ';
  11607.         $current_depth              = $starting_depth;
  11608.         $i                          = -1;
  11609.         $last_colon_sequence_number = -1;
  11610.         $last_nonblank_token        = ';';
  11611.         $last_nonblank_type         = ';';
  11612.         $last_old_breakpoint_count  = 0;
  11613.         $minimum_depth = $current_depth + 1;    # forces update in check below
  11614.         $old_breakpoint_count      = 0;
  11615.         $starting_breakpoint_count = $forced_breakpoint_count;
  11616.         $token                     = ';';
  11617.         $type                      = ';';
  11618.         $type_sequence             = '';
  11619.  
  11620.         check_for_new_minimum_depth($current_depth);
  11621.  
  11622.         my $is_long_line = excess_line_length( 0, $max_index_to_go ) > 0;
  11623.         my $want_previous_breakpoint = -1;
  11624.  
  11625.         my $saw_good_breakpoint;
  11626.         my $i_line_end   = -1;
  11627.         my $i_line_start = -1;
  11628.  
  11629.         # loop over all tokens in this batch
  11630.         while ( ++$i <= $max_index_to_go ) {
  11631.             if ( $type ne 'b' ) {
  11632.                 $i_last_nonblank_token = $i - 1;
  11633.                 $last_nonblank_type    = $type;
  11634.                 $last_nonblank_token   = $token;
  11635.             }
  11636.             $type          = $types_to_go[$i];
  11637.             $block_type    = $block_type_to_go[$i];
  11638.             $token         = $tokens_to_go[$i];
  11639.             $type_sequence = $type_sequence_to_go[$i];
  11640.             my $next_type       = $types_to_go[ $i + 1 ];
  11641.             my $next_token      = $tokens_to_go[ $i + 1 ];
  11642.             my $i_next_nonblank = ( ( $next_type eq 'b' ) ? $i + 2 : $i + 1 );
  11643.             $next_nonblank_type       = $types_to_go[$i_next_nonblank];
  11644.             $next_nonblank_token      = $tokens_to_go[$i_next_nonblank];
  11645.             $next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
  11646.  
  11647.             # set break if flag was set
  11648.             if ( $want_previous_breakpoint >= 0 ) {
  11649.                 set_forced_breakpoint($want_previous_breakpoint);
  11650.                 $want_previous_breakpoint = -1;
  11651.             }
  11652.  
  11653.             $last_old_breakpoint_count = $old_breakpoint_count;
  11654.             if ( $old_breakpoint_to_go[$i] ) {
  11655.                 $i_line_end   = $i;
  11656.                 $i_line_start = $i_next_nonblank;
  11657.  
  11658.                 $old_breakpoint_count++;
  11659.  
  11660.                 # Break before certain keywords if user broke there and
  11661.                 # this is a 'safe' break point. The idea is to retain
  11662.                 # any preferred breaks for sequential list operations,
  11663.                 # like a schwartzian transform.
  11664.                 if ($rOpts_break_at_old_keyword_breakpoints) {
  11665.                     if (
  11666.                            $next_nonblank_type eq 'k'
  11667.                         && $is_keyword_returning_list{$next_nonblank_token}
  11668.                         && (   $type =~ /^[=\)\]\}Riw]$/
  11669.                             || $type eq 'k'
  11670.                             && $is_keyword_returning_list{$token} )
  11671.                       )
  11672.                     {
  11673.  
  11674.                         # we actually have to set this break next time through
  11675.                         # the loop because if we are at a closing token (such
  11676.                         # as '}') which forms a one-line block, this break might
  11677.                         # get undone.
  11678.                         $want_previous_breakpoint = $i;
  11679.                     }
  11680.                 }
  11681.             }
  11682.             next if ( $type eq 'b' );
  11683.             $depth = $nesting_depth_to_go[ $i + 1 ];
  11684.  
  11685.             # safety check - be sure we always break after a comment
  11686.             # Shouldn't happen .. an error here probably means that the
  11687.             # nobreak flag did not get turned off correctly during
  11688.             # formatting.
  11689.             if ( $type eq '#' ) {
  11690.                 if ( $i != $max_index_to_go ) {
  11691.                     warning(
  11692. "Non-fatal program bug: backup logic needed to break after a comment\n"
  11693.                     );
  11694.                     report_definite_bug();
  11695.                     $nobreak_to_go[$i] = 0;
  11696.                     set_forced_breakpoint($i);
  11697.                 }
  11698.             }
  11699.  
  11700.             # Force breakpoints at certain tokens in long lines.
  11701.             # Note that such breakpoints will be undone later if these tokens
  11702.             # are fully contained within parens on a line.
  11703.             if (
  11704.                    $type eq 'k'
  11705.                 && $i > 0
  11706.                 && $token =~ /^(if|unless)$/
  11707.                 && (
  11708.                     $is_long_line
  11709.  
  11710.                     # or container is broken (by side-comment, etc)
  11711.                     || (   $next_nonblank_token eq '('
  11712.                         && $mate_index_to_go[$i_next_nonblank] < $i )
  11713.                 )
  11714.               )
  11715.             {
  11716.                 set_forced_breakpoint( $i - 1 );
  11717.             }
  11718.  
  11719.             # remember locations of '||'  and '&&' for possible breaks if we
  11720.             # decide this is a long logical expression.
  11721.             if ( $type eq '||' ) {
  11722.                 push @{ $rand_or_list[$depth][2] }, $i;
  11723.                 ++$has_old_logical_breakpoints[$depth]
  11724.                   if ( ( $i == $i_line_start || $i == $i_line_end )
  11725.                     && $rOpts_break_at_old_logical_breakpoints );
  11726.             }
  11727.             elsif ( $type eq '&&' ) {
  11728.                 push @{ $rand_or_list[$depth][3] }, $i;
  11729.                 ++$has_old_logical_breakpoints[$depth]
  11730.                   if ( ( $i == $i_line_start || $i == $i_line_end )
  11731.                     && $rOpts_break_at_old_logical_breakpoints );
  11732.             }
  11733.             elsif ( $type eq 'f' ) {
  11734.                 push @{ $rfor_semicolon_list[$depth] }, $i;
  11735.             }
  11736.             elsif ( $type eq 'k' ) {
  11737.                 if ( $token eq 'and' ) {
  11738.                     push @{ $rand_or_list[$depth][1] }, $i;
  11739.                     ++$has_old_logical_breakpoints[$depth]
  11740.                       if ( ( $i == $i_line_start || $i == $i_line_end )
  11741.                         && $rOpts_break_at_old_logical_breakpoints );
  11742.                 }
  11743.  
  11744.                 # break immediately at 'or's which are probably not in a logical
  11745.                 # block -- but we will break in logical breaks below so that
  11746.                 # they do not add to the forced_breakpoint_count
  11747.                 elsif ( $token eq 'or' ) {
  11748.                     push @{ $rand_or_list[$depth][0] }, $i;
  11749.                     ++$has_old_logical_breakpoints[$depth]
  11750.                       if ( ( $i == $i_line_start || $i == $i_line_end )
  11751.                         && $rOpts_break_at_old_logical_breakpoints );
  11752.                     if ( $is_logical_container{ $container_type[$depth] } ) {
  11753.                     }
  11754.                     else {
  11755.                         if ($is_long_line) { set_forced_breakpoint($i) }
  11756.                         elsif ( ( $i == $i_line_start || $i == $i_line_end )
  11757.                             && $rOpts_break_at_old_logical_breakpoints )
  11758.                         {
  11759.                             $saw_good_breakpoint = 1;
  11760.                         }
  11761.                     }
  11762.                 }
  11763.                 elsif ( $token eq 'if' || $token eq 'unless' ) {
  11764.                     push @{ $rand_or_list[$depth][4] }, $i;
  11765.                     if ( ( $i == $i_line_start || $i == $i_line_end )
  11766.                         && $rOpts_break_at_old_logical_breakpoints )
  11767.                     {
  11768.                         set_forced_breakpoint($i);
  11769.                     }
  11770.                 }
  11771.             }
  11772.             elsif ( $type eq '=' ) {
  11773.                 $i_equals[$depth] = $i;
  11774.             }
  11775.  
  11776.             if ($type_sequence) {
  11777.  
  11778.                 # handle any postponed closing breakpoints
  11779.                 if ( $token =~ /^[\)\]\}\:]$/ ) {
  11780.                     if ( $token eq ':' ) {
  11781.                         $last_colon_sequence_number = $type_sequence;
  11782.  
  11783.                         # TESTING: retain break at a ':' line break
  11784.                         if ( ( $i == $i_line_start || $i == $i_line_end )
  11785.                             && $rOpts_break_at_old_trinary_breakpoints )
  11786.                         {
  11787.  
  11788.                             # TESTING:
  11789.                             set_forced_breakpoint($i);
  11790.  
  11791.                             # break at previous '='
  11792.                             if ( $i_equals[$depth] > 0 ) {
  11793.                                 set_forced_breakpoint( $i_equals[$depth] );
  11794.                                 $i_equals[$depth] = -1;
  11795.                             }
  11796.                         }
  11797.                     }
  11798.                     if ( defined( $postponed_breakpoint{$type_sequence} ) ) {
  11799.                         my $inc = ( $token eq ':' ) ? 0 : 1;
  11800.                         set_forced_breakpoint( $i - $inc );
  11801.                         delete $postponed_breakpoint{$type_sequence};
  11802.                     }
  11803.                 }
  11804.  
  11805.                 # set breaks at ?/: if they will get separated (and are
  11806.                 # not a ?/: chain), or if the '?' is at the end of the
  11807.                 # line
  11808.                 elsif ( $token eq '?' ) {
  11809.                     my $i_colon = $mate_index_to_go[$i];
  11810.                     if (
  11811.                         $i_colon <= 0  # the ':' is not in this batch
  11812.                         || $i == 0     # this '?' is the first token of the line
  11813.                         || $i ==
  11814.                         $max_index_to_go    # or this '?' is the last token
  11815.                       )
  11816.                     {
  11817.  
  11818.                         # don't break at a '?' if preceded by ':' on
  11819.                         # this line of previous ?/: pair on this line.
  11820.                         # This is an attempt to preserve a chain of ?/:
  11821.                         # expressions (elsif2.t).  And don't break if
  11822.                         # this has a side comment.
  11823.                         set_forced_breakpoint($i)
  11824.                           unless (
  11825.                             $type_sequence == (
  11826.                                 $last_colon_sequence_number +
  11827.                                   TYPE_SEQUENCE_INCREMENT
  11828.                             )
  11829.                             || $tokens_to_go[$max_index_to_go] eq '#'
  11830.                           );
  11831.                         set_closing_breakpoint($i);
  11832.                     }
  11833.                 }
  11834.             }
  11835.  
  11836. #print "LISTX sees: i=$i type=$type  tok=$token  block=$block_type depth=$depth\n";
  11837.  
  11838.             #------------------------------------------------------------
  11839.             # Handle Increasing Depth..
  11840.             #
  11841.             # prepare for a new list when depth increases
  11842.             # token $i is a '(','{', or '['
  11843.             #------------------------------------------------------------
  11844.             if ( $depth > $current_depth ) {
  11845.  
  11846.                 $breakpoint_stack[$depth]       = $forced_breakpoint_count;
  11847.                 $breakpoint_undo_stack[$depth]  = $forced_breakpoint_undo_count;
  11848.                 $has_broken_sublist[$depth]     = 0;
  11849.                 $identifier_count_stack[$depth] = 0;
  11850.                 $index_before_arrow[$depth]     = -1;
  11851.                 $interrupted_list[$depth]       = 0;
  11852.                 $item_count_stack[$depth]       = 0;
  11853.                 $last_comma_index[$depth]       = undef;
  11854.                 $last_dot_index[$depth]         = undef;
  11855.                 $last_nonblank_type[$depth]     = $last_nonblank_type;
  11856.                 $old_breakpoint_count_stack[$depth]    = $old_breakpoint_count;
  11857.                 $opening_structure_index_stack[$depth] = $i;
  11858.                 $rand_or_list[$depth]                  = [];
  11859.                 $rfor_semicolon_list[$depth]           = [];
  11860.                 $i_equals[$depth]                      = -1;
  11861.                 $want_comma_break[$depth]              = 0;
  11862.                 $container_type[$depth]                =
  11863.                   ( $last_nonblank_type =~ /^(k|=>|&&|\|\||\?|\:|\.)$/ )
  11864.                   ? $last_nonblank_token
  11865.                   : "";
  11866.                 $has_old_logical_breakpoints[$depth] = 0;
  11867.  
  11868.                 # if line ends here then signal closing token to break
  11869.                 if ( $next_nonblank_type eq 'b' || $next_nonblank_type eq '#' )
  11870.                 {
  11871.                     set_closing_breakpoint($i);
  11872.                 }
  11873.  
  11874.                 # Not all lists of values should be vertically aligned..
  11875.                 $dont_align[$depth] =
  11876.  
  11877.                   # code BLOCKS are handled at a higher level
  11878.                   ( $block_type ne "" )
  11879.  
  11880.                   # certain paren lists
  11881.                   || ( $type eq '(' ) && (
  11882.  
  11883.                     # it does not usually look good to align a list of
  11884.                     # identifiers in a parameter list, as in:
  11885.                     #    my($var1, $var2, ...)
  11886.                     # (This test should probably be refined, for now I'm just
  11887.                     # testing for any keyword)
  11888.                     ( $last_nonblank_type eq 'k' )
  11889.  
  11890.                     # a trailing '(' usually indicates a non-list
  11891.                     || ( $next_nonblank_type eq '(' )
  11892.                   );
  11893.  
  11894.                 # patch to outdent opening brace of long if/for/..
  11895.                 # statements (like this one).  See similar coding in
  11896.                 # set_continuation breaks.  We have also catch it here for
  11897.                 # short line fragments which otherwise will not go through
  11898.                 # set_continuation_breaks.
  11899.                 if (
  11900.                     $block_type
  11901.  
  11902.                     # if we have the ')' but not its '(' in this batch..
  11903.                     && ( $last_nonblank_token eq ')' )
  11904.                     && $mate_index_to_go[$i_last_nonblank_token] < 0
  11905.  
  11906.                     # and user wants brace to left
  11907.                     && !$rOpts->{'opening-brace-always-on-right'}
  11908.  
  11909.                     && ( $type  eq '{' )    # should be true
  11910.                     && ( $token eq '{' )    # should be true
  11911.                   )
  11912.                 {
  11913.                     set_forced_breakpoint( $i - 1 );
  11914.                 }
  11915.             }
  11916.  
  11917.             #------------------------------------------------------------
  11918.             # Handle Decreasing Depth..
  11919.             #
  11920.             # finish off any old list when depth decreases
  11921.             # token $i is a ')','}', or ']'
  11922.             #------------------------------------------------------------
  11923.             elsif ( $depth < $current_depth ) {
  11924.  
  11925.                 check_for_new_minimum_depth($depth);
  11926.  
  11927.                 # force all outer logical containers to break after we see on
  11928.                 # old breakpoint
  11929.                 $has_old_logical_breakpoints[$depth] ||=
  11930.                   $has_old_logical_breakpoints[$current_depth];
  11931.  
  11932.                 # Patch to break between ') {' if the paren list is broken.
  11933.                 # There is similar logic in set_continuation_breaks for
  11934.                 # non-broken lists.
  11935.                 if (   $token eq ')'
  11936.                     && $next_nonblank_block_type
  11937.                     && $interrupted_list[$current_depth]
  11938.                     && $next_nonblank_type eq '{'
  11939.                     && !$rOpts->{'opening-brace-always-on-right'} )
  11940.                 {
  11941.                     set_forced_breakpoint($i);
  11942.                 }
  11943.  
  11944. #print "LISTY sees: i=$i type=$type  tok=$token  block=$block_type depth=$depth next=$next_nonblank_type next_block=$next_nonblank_block_type inter=$interrupted_list[$current_depth]\n";
  11945.  
  11946.                 # set breaks at commas if necessary
  11947.                 my ( $bp_count, $do_not_break_apart ) =
  11948.                   set_comma_breakpoints($current_depth);
  11949.  
  11950.                 my $i_opening = $opening_structure_index_stack[$current_depth];
  11951.                 my $saw_opening_structure = ( $i_opening >= 0 );
  11952.  
  11953.                 # this term is long if we had to break at interior commas..
  11954.                 my $is_long_term = $bp_count > 0;
  11955.  
  11956.                 # ..or if the length between opening and closing parens exceeds
  11957.                 # allowed line length
  11958.                 if ( !$is_long_term && $saw_opening_structure ) {
  11959.                     my $i_opening_minus = find_token_starting_list($i_opening);
  11960.  
  11961.                     # Note: we have to allow for one extra space after a
  11962.                     # closing token so that we do not strand a comma or
  11963.                     # semicolon, hence the '>=' here (oneline.t)
  11964.                     $is_long_term =
  11965.                       excess_line_length( $i_opening_minus, $i ) >= 0;
  11966.                 }
  11967.  
  11968.                 # We've set breaks after all comma-arrows.  Now we have to
  11969.                 # undo them if this can be a one-line block
  11970.                 # (the only breakpoints set will be due to comma-arrows)
  11971.                 if (
  11972.  
  11973.                     # user doesn't require breaking after all comma-arrows
  11974.                     ( $rOpts_comma_arrow_breakpoints != 0 )
  11975.  
  11976.                     # and if the opening structure is in this batch
  11977.                     && $saw_opening_structure
  11978.  
  11979.                     # and either on the same old line
  11980.                     && (
  11981.                         $old_breakpoint_count_stack[$current_depth] ==
  11982.                         $last_old_breakpoint_count
  11983.  
  11984.                         # or user wants to form long blocks with arrows
  11985.                         || $rOpts_comma_arrow_breakpoints == 2
  11986.                     )
  11987.  
  11988.                   # and we made some breakpoints between the opening and closing
  11989.                     && ( $breakpoint_undo_stack[$current_depth] <
  11990.                         $forced_breakpoint_undo_count )
  11991.  
  11992.                     # and this block is short enough to fit on one line
  11993.                     # Note: use < because need 1 more space for possible comma
  11994.                     && !$is_long_term
  11995.  
  11996.                   )
  11997.                 {
  11998.                     undo_forced_breakpoint_stack(
  11999.                         $breakpoint_undo_stack[$current_depth] );
  12000.                 }
  12001.  
  12002.                 # now see if we have any comma breakpoints left
  12003.                 my $has_comma_breakpoints =
  12004.                   ( $breakpoint_stack[$current_depth] !=
  12005.                       $forced_breakpoint_count );
  12006.  
  12007.                 # update broken-sublist flag of the outer container
  12008.                      $has_broken_sublist[$depth] = $has_broken_sublist[$depth]
  12009.                   || $has_broken_sublist[$current_depth]
  12010.                   || $is_long_term
  12011.                   || $has_comma_breakpoints;
  12012.  
  12013. # Having come to the closing ')', '}', or ']', now we have to decide if we
  12014. # should 'open up' the structure by placing breaks at the opening and
  12015. # closing containers.  This is a tricky decision.  Here are some of the
  12016. # basic considerations:
  12017. #
  12018. # -If this is a BLOCK container, then any breakpoints will have already
  12019. # been set (and according to user preferences), so we need do nothing here.
  12020. #
  12021. # -If we have a comma-separated list for which we can align the list items,
  12022. # then we need to do so because otherwise the vertical aligner cannot
  12023. # currently do the alignment.
  12024. #
  12025. # -If this container does itself contain a container which has been broken
  12026. # open, then it should be broken open to properly show the structure.
  12027. #
  12028. # -If there is nothing to align, and no other reason to break apart,
  12029. # then do not do it.
  12030. #
  12031. # We will not break open the parens of a long but 'simple' logical expression.
  12032. # For example:
  12033. #
  12034. # This is an example of a simple logical expression and its formatting:
  12035. #
  12036. #     if ( $bigwasteofspace1 && $bigwasteofspace2
  12037. #         || $bigwasteofspace3 && $bigwasteofspace4 )
  12038. #
  12039. # Most people would prefer this than the 'spacey' version:
  12040. #
  12041. #     if (
  12042. #         $bigwasteofspace1 && $bigwasteofspace2
  12043. #         || $bigwasteofspace3 && $bigwasteofspace4
  12044. #     )
  12045. #
  12046. # To illustrate the rules for breaking logical expressions, consider:
  12047. #
  12048. #             FULLY DENSE:
  12049. #             if ( $opt_excl
  12050. #                 and ( exists $ids_excl_uc{$id_uc}
  12051. #                     or grep $id_uc =~ /$_/, @ids_excl_uc ))
  12052. #
  12053. # This is on the verge of being difficult to read.  The current default is to
  12054. # open it up like this:
  12055. #
  12056. #             DEFAULT:
  12057. #             if (
  12058. #                 $opt_excl
  12059. #                 and ( exists $ids_excl_uc{$id_uc}
  12060. #                     or grep $id_uc =~ /$_/, @ids_excl_uc )
  12061. #               )
  12062. #
  12063. # This is a compromise which tries to avoid being too dense and to spacey.
  12064. # A more spaced version would be:
  12065. #
  12066. #             SPACEY:
  12067. #             if (
  12068. #                 $opt_excl
  12069. #                 and (
  12070. #                     exists $ids_excl_uc{$id_uc}
  12071. #                     or grep $id_uc =~ /$_/, @ids_excl_uc
  12072. #                 )
  12073. #               )
  12074. #
  12075. # Some people might prefer the spacey version -- an option could be added.  The
  12076. # innermost expression contains a long block '( exists $ids_...  ')'.
  12077. #
  12078. # Here is how the logic goes: We will force a break at the 'or' that the
  12079. # innermost expression contains, but we will not break apart its opening and
  12080. # closing containers because (1) it contains no multi-line sub-containers itself,
  12081. # and (2) there is no alignment to be gained by breaking it open like this
  12082. #
  12083. #             and (
  12084. #                 exists $ids_excl_uc{$id_uc}
  12085. #                 or grep $id_uc =~ /$_/, @ids_excl_uc
  12086. #             )
  12087. #
  12088. # (although this looks perfectly ok and might be good for long expressions).  The
  12089. # outer 'if' container, though, contains a broken sub-container, so it will be
  12090. # broken open to avoid too much density.  Also, since it contains no 'or's, there
  12091. # will be a forced break at its 'and'.
  12092.  
  12093.                 # set some flags telling something about this container..
  12094.                 my $is_simple_logical_expression = 0;
  12095.                 if (   $item_count_stack[$current_depth] == 0
  12096.                     && $saw_opening_structure
  12097.                     && $tokens_to_go[$i_opening] eq '('
  12098.                     && $is_logical_container{ $container_type[$current_depth] }
  12099.                   )
  12100.                 {
  12101.  
  12102.                     # This seems to be a simple logical expression with
  12103.                     # no existing breakpoints.  Set a flag to prevent
  12104.                     # opening it up.
  12105.                     if ( !$has_comma_breakpoints ) {
  12106.                         $is_simple_logical_expression = 1;
  12107.                     }
  12108.  
  12109.                     # This seems to be a simple logical expression with
  12110.                     # breakpoints (broken sublists, for example).  Break
  12111.                     # at all 'or's and '||'s.
  12112.                     else {
  12113.                         set_logical_breakpoints($current_depth);
  12114.                     }
  12115.                 }
  12116.  
  12117.                 if ( $is_long_term
  12118.                     && @{ $rfor_semicolon_list[$current_depth] } )
  12119.                 {
  12120.                     set_for_semicolon_breakpoints($current_depth);
  12121.  
  12122.                     # open up a long 'for' or 'foreach' container to allow
  12123.                     # leading term alignment unless -lp is used.
  12124.                     $has_comma_breakpoints = 1
  12125.                       unless $rOpts_line_up_parentheses;
  12126.                 }
  12127.  
  12128.                 if (
  12129.  
  12130.                     # breaks for code BLOCKS are handled at a higher level
  12131.                     !$block_type
  12132.  
  12133.                     # we do not need to break at the top level of an 'if'
  12134.                     # type expression
  12135.                     && !$is_simple_logical_expression
  12136.  
  12137.                     ## modification to keep ': (' containers vertically tight;
  12138.                     ## but probably better to let user set -vt=1 to avoid
  12139.                     ## inconsistency with other paren types
  12140.                     ## && ($container_type[$current_depth] ne ':')
  12141.  
  12142.                     # otherwise, we require one of these reasons for breaking:
  12143.                     && (
  12144.  
  12145.                         # - this term has forced line breaks
  12146.                         $has_comma_breakpoints
  12147.  
  12148.                        # - the opening container is separated from this batch
  12149.                        #   for some reason (comment, blank line, code block)
  12150.                        # - this is a non-paren container spanning multiple lines
  12151.                         || !$saw_opening_structure
  12152.  
  12153.                         # - this is a long block contained in another breakable
  12154.                         #   container
  12155.                         || (   $is_long_term
  12156.                             && $container_environment_to_go[$i_opening] ne
  12157.                             'BLOCK' )
  12158.                     )
  12159.                   )
  12160.                 {
  12161.  
  12162.                     # For -lp option, we must put a breakpoint before
  12163.                     # the token which has been identified as starting
  12164.                     # this indentation level.  This is necessary for
  12165.                     # proper alignment.
  12166.                     if ( $rOpts_line_up_parentheses && $saw_opening_structure )
  12167.                     {
  12168.                         my $item = $leading_spaces_to_go[ $i_opening + 1 ];
  12169.                         if ( defined($item) ) {
  12170.                             my $i_start_2 = $item->get_STARTING_INDEX();
  12171.                             if (
  12172.                                 defined($i_start_2)
  12173.  
  12174.                                 # we are breaking after an opening brace, paren,
  12175.                                 # so don't break before it too
  12176.                                 && $i_start_2 ne $i_opening
  12177.                               )
  12178.                             {
  12179.  
  12180.                                 # Only break for breakpoints at the same
  12181.                                 # indentation level as the opening paren
  12182.                                 my $test1 = $nesting_depth_to_go[$i_opening];
  12183.                                 my $test2 = $nesting_depth_to_go[$i_start_2];
  12184.                                 if ( $test2 == $test1 ) {
  12185.                                     set_forced_breakpoint( $i_start_2 - 1 );
  12186.                                 }
  12187.                             }
  12188.                         }
  12189.                     }
  12190.  
  12191.                     # break after opening structure.
  12192.                     # note: break before closing structure will be automatic
  12193.                     if ( $minimum_depth <= $current_depth ) {
  12194.  
  12195.                         set_forced_breakpoint($i_opening)
  12196.                           unless ( $do_not_break_apart
  12197.                             || is_unbreakable_container($current_depth) );
  12198.  
  12199.                         # break at '.' of lower depth level before opening token
  12200.                         if ( $last_dot_index[$depth] ) {
  12201.                             set_forced_breakpoint( $last_dot_index[$depth] );
  12202.                         }
  12203.  
  12204.                         # break before opening structure if preeced by another
  12205.                         # closing structure and a comma.  This is normally
  12206.                         # done by the previous closing brace, but not
  12207.                         # if it was a one-line block.
  12208.                         if ( $i_opening > 2 ) {
  12209.                             my $i_prev =
  12210.                               ( $types_to_go[ $i_opening - 1 ] eq 'b' )
  12211.                               ? $i_opening - 2
  12212.                               : $i_opening - 1;
  12213.  
  12214.                             if (   $types_to_go[$i_prev] eq ','
  12215.                                 && $types_to_go[ $i_prev - 1 ] =~ /^[\)\}]$/ )
  12216.                             {
  12217.                                 set_forced_breakpoint($i_prev);
  12218.                             }
  12219.  
  12220.                             # also break before something like ':('  or '?('
  12221.                             # if appropriate.
  12222.                             elsif (
  12223.                                 $types_to_go[$i_prev] =~ /^([\:\?]|&&|\|\|)$/ )
  12224.                             {
  12225.                                 my $token_prev = $tokens_to_go[$i_prev];
  12226.                                 if ( $want_break_before{$token_prev} ) {
  12227.                                     set_forced_breakpoint($i_prev);
  12228.                                 }
  12229.                             }
  12230.                         }
  12231.                     }
  12232.  
  12233.                     # break after comma following closing structure
  12234.                     if ( $next_type eq ',' ) {
  12235.                         set_forced_breakpoint( $i + 1 );
  12236.                     }
  12237.  
  12238.                     # break before an '=' following closing structure
  12239.                     if (
  12240.                         $next_nonblank_type eq '='
  12241.                         && ( $breakpoint_stack[$current_depth] !=
  12242.                             $forced_breakpoint_count )
  12243.                       )
  12244.                     {
  12245.                         set_forced_breakpoint($i);
  12246.                     }
  12247.  
  12248.                     # break at any comma before the opening structure Added
  12249.                     # for -lp, but seems to be good in general.  It isn't
  12250.                     # obvious how far back to look; the '5' below seems to
  12251.                     # work well and will catch the comma in something like
  12252.                     #  push @list, myfunc( $param, $param, ..
  12253.  
  12254.                     my $icomma = $last_comma_index[$depth];
  12255.                     if ( defined($icomma) && ( $i_opening - $icomma ) < 5 ) {
  12256.                         unless ( $forced_breakpoint_to_go[$icomma] ) {
  12257.                             set_forced_breakpoint($icomma);
  12258.                         }
  12259.                     }
  12260.                 }    # end logic to open up a container
  12261.  
  12262.                 # Break open a logical container open if it was already open
  12263.                 elsif ($is_simple_logical_expression
  12264.                     && $has_old_logical_breakpoints[$current_depth] )
  12265.                 {
  12266.                     set_logical_breakpoints($current_depth);
  12267.                 }
  12268.  
  12269.                 # Handle long container which does not get opened up
  12270.                 elsif ($is_long_term) {
  12271.  
  12272.                     # must set fake breakpoint to alert outer containers that
  12273.                     # they are complex
  12274.                     set_fake_breakpoint();
  12275.                 }
  12276.             }
  12277.  
  12278.             #------------------------------------------------------------
  12279.             # Handle this token
  12280.             #------------------------------------------------------------
  12281.  
  12282.             $current_depth = $depth;
  12283.  
  12284.             # handle comma-arrow
  12285.             if ( $type eq '=>' ) {
  12286.                 next if ( $last_nonblank_type eq '=>' );
  12287.                 next if $rOpts_break_at_old_comma_breakpoints;
  12288.                 next if $rOpts_comma_arrow_breakpoints == 3;
  12289.                 $want_comma_break[$depth]   = 1;
  12290.                 $index_before_arrow[$depth] = $i_last_nonblank_token;
  12291.                 next;
  12292.             }
  12293.  
  12294.             elsif ( $type eq '.' ) {
  12295.                 $last_dot_index[$depth] = $i;
  12296.             }
  12297.  
  12298.             # Turn off alignment if we are sure that this is not a list
  12299.             # environment.  To be safe, we will do this if we see certain
  12300.             # non-list tokens, such as ';', and also the environment is
  12301.             # not a list.  Note that '=' could be in any of the = operators
  12302.             # (lextest.t). We can't just use the reported environment
  12303.             # because it can be incorrect in some cases.
  12304.             elsif ($type =~ /(^[\;\<\>\~]$)|[=]/
  12305.                 && $container_environment_to_go[$i] ne 'LIST' )
  12306.             {
  12307.                 $dont_align[$depth]         = 1;
  12308.                 $want_comma_break[$depth]   = 0;
  12309.                 $index_before_arrow[$depth] = -1;
  12310.             }
  12311.  
  12312.             # now just handle any commas
  12313.             next unless ( $type eq ',' );
  12314.  
  12315.             $last_dot_index[$depth]   = undef;
  12316.             $last_comma_index[$depth] = $i;
  12317.  
  12318.             # break here if this comma follows a '=>'
  12319.             # but not if there is a side comment after the comma
  12320.             if ( $want_comma_break[$depth] ) {
  12321.  
  12322.                 if ( $next_nonblank_type =~ /^[\)\}\]R]$/ ) {
  12323.                     $want_comma_break[$depth]   = 0;
  12324.                     $index_before_arrow[$depth] = -1;
  12325.                     next;
  12326.                 }
  12327.  
  12328.                 set_forced_breakpoint($i) unless ( $next_nonblank_type eq '#' );
  12329.  
  12330.                 # break before the previous token if it looks safe
  12331.                 # Example of something that we will not try to break before:
  12332.                 #   DBI::SQL_SMALLINT() => $ado_consts->{adSmallInt},
  12333.                 my $ibreak = $index_before_arrow[$depth] - 1;
  12334.                 if (   $ibreak > 0
  12335.                     && $tokens_to_go[ $ibreak + 1 ] !~ /^[\)\}\]]$/ )
  12336.                 {
  12337.                     if ( $tokens_to_go[$ibreak] eq '-' ) { $ibreak-- }
  12338.                     if ( $types_to_go[$ibreak] =~ /^[,b\(\{\[]$/ ) {
  12339.                         set_forced_breakpoint($ibreak);
  12340.                     }
  12341.                 }
  12342.  
  12343.                 $want_comma_break[$depth]   = 0;
  12344.                 $index_before_arrow[$depth] = -1;
  12345.  
  12346.                 # handle list which mixes '=>'s and ','s:
  12347.                 # treat any list items so far as an interrupted list
  12348.                 $interrupted_list[$depth] = 1;
  12349.                 next;
  12350.             }
  12351.  
  12352.             # skip past these commas if we are not supposed to format them
  12353.             next if ( $dont_align[$depth] );
  12354.  
  12355.             # break after all commas above starting depth
  12356.             if ( $depth < $starting_depth ) {
  12357.                 set_forced_breakpoint($i) unless ( $next_nonblank_type eq '#' );
  12358.                 next;
  12359.             }
  12360.  
  12361.             # add this comma to the list..
  12362.             my $item_count = $item_count_stack[$depth];
  12363.             if ( $item_count == 0 ) {
  12364.  
  12365.                 # but do not form a list with no opening structure
  12366.                 # for example:
  12367.  
  12368.                 #            open INFILE_COPY, ">$input_file_copy"
  12369.                 #              or die ("very long message");
  12370.  
  12371.                 if ( ( $opening_structure_index_stack[$depth] < 0 )
  12372.                     && $container_environment_to_go[$i] eq 'BLOCK' )
  12373.                 {
  12374.                     $dont_align[$depth] = 1;
  12375.                     next;
  12376.                 }
  12377.             }
  12378.  
  12379.             $comma_index[$depth][$item_count] = $i;
  12380.             ++$item_count_stack[$depth];
  12381.             if ( $last_nonblank_type =~ /^[iR\]]$/ ) {
  12382.                 $identifier_count_stack[$depth]++;
  12383.             }
  12384.         }
  12385.  
  12386.         #-------------------------------------------
  12387.         # end of loop over all tokens in this batch
  12388.         #-------------------------------------------
  12389.  
  12390.         # set breaks for any unfinished lists ..
  12391.         for ( my $dd = $current_depth ; $dd >= $minimum_depth ; $dd-- ) {
  12392.  
  12393.             $interrupted_list[$dd] = 1;
  12394.             $has_broken_sublist[$dd] = 1 if ( $dd < $current_depth );
  12395.             set_comma_breakpoints($dd);
  12396.             set_logical_breakpoints($dd)
  12397.               if ( $has_old_logical_breakpoints[$dd] );
  12398.             set_for_semicolon_breakpoints($dd);
  12399.  
  12400.             # break open container...
  12401.             my $i_opening = $opening_structure_index_stack[$dd];
  12402.             set_forced_breakpoint($i_opening)
  12403.               unless (
  12404.                 is_unbreakable_container($dd)
  12405.  
  12406.                 # Avoid a break which would place an isolated ' or "
  12407.                 # on a line
  12408.                 || (   $type eq 'Q'
  12409.                     && $i_opening >= $max_index_to_go - 2
  12410.                     && $token =~ /^['"]$/ )
  12411.               );
  12412.         }
  12413.  
  12414.         # Return a flag indicating if the input file had some good breakpoints.
  12415.         # This flag will be used to force a break in a line shorter than the
  12416.         # allowed line length.
  12417.         if ( $has_old_logical_breakpoints[$current_depth] ) {
  12418.             $saw_good_breakpoint = 1;
  12419.         }
  12420.         return $saw_good_breakpoint;
  12421.     }
  12422. }    # end scan_list
  12423.  
  12424. sub find_token_starting_list {
  12425.  
  12426.     # When testing to see if a block will fit on one line, some
  12427.     # previous token(s) may also need to be on the line; particularly
  12428.     # if this is a sub call.  So we will look back at least one
  12429.     # token. NOTE: This isn't perfect, but not critical, because
  12430.     # if we mis-identify a block, it will be wrapped and therefore
  12431.     # fixed the next time it is formatted.
  12432.     my $i_opening_paren = shift;
  12433.     my $i_opening_minus = $i_opening_paren;
  12434.     my $im1             = $i_opening_paren - 1;
  12435.     my $im2             = $i_opening_paren - 2;
  12436.     my $im3             = $i_opening_paren - 3;
  12437.     my $typem1          = $types_to_go[$im1];
  12438.     my $typem2          = $im2 >= 0 ? $types_to_go[$im2] : 'b';
  12439.     if ( $typem1 eq ',' || ( $typem1 eq 'b' && $typem2 eq ',' ) ) {
  12440.         $i_opening_minus = $i_opening_paren;
  12441.     }
  12442.     elsif ( $tokens_to_go[$i_opening_paren] eq '(' ) {
  12443.         $i_opening_minus = $im1 if $im1 >= 0;
  12444.  
  12445.         # walk back to improve length estimate
  12446.         for ( my $j = $im1 ; $j >= 0 ; $j-- ) {
  12447.             last if ( $types_to_go[$j] =~ /^[\(\[\{L\}\]\)Rb,]$/ );
  12448.             $i_opening_minus = $j;
  12449.         }
  12450.         if ( $types_to_go[$i_opening_minus] eq 'b' ) { $i_opening_minus++ }
  12451.     }
  12452.     elsif ( $typem1 eq 'k' ) { $i_opening_minus = $im1 }
  12453.     elsif ( $typem1 eq 'b' && $im2 >= 0 && $types_to_go[$im2] eq 'k' ) {
  12454.         $i_opening_minus = $im2;
  12455.     }
  12456.     return $i_opening_minus;
  12457. }
  12458.  
  12459. {    # begin set_comma_breakpoints_do
  12460.  
  12461.     my %is_keyword_with_special_leading_term;
  12462.  
  12463.     BEGIN {
  12464.  
  12465.         # These keywords have prototypes which allow a special leading item
  12466.         # followed by a list
  12467.         @_ =
  12468.           qw(formline grep kill map printf sprintf push chmod join pack unshift);
  12469.         @is_keyword_with_special_leading_term{@_} = (1) x scalar(@_);
  12470.     }
  12471.  
  12472.     sub set_comma_breakpoints_do {
  12473.  
  12474.         # Given a list with some commas, set breakpoints at some of the
  12475.         # commas, if necessary, to make it easy to read.  This list is
  12476.         # an example:
  12477.         my (
  12478.             $depth,               $i_opening_paren,  $i_closing_paren,
  12479.             $item_count,          $identifier_count, $rcomma_index,
  12480.             $next_nonblank_type,  $list_type,        $interrupted,
  12481.             $rdo_not_break_apart, $must_break_open,
  12482.           )
  12483.           = @_;
  12484.  
  12485.         # nothing to do if no commas seen
  12486.         return if ( $item_count < 1 );
  12487.         my $i_first_comma     = $$rcomma_index[0];
  12488.         my $i_true_last_comma = $$rcomma_index[ $item_count - 1 ];
  12489.         my $i_last_comma      = $i_true_last_comma;
  12490.         if ( $i_last_comma >= $max_index_to_go ) {
  12491.             $i_last_comma = $$rcomma_index[ --$item_count - 1 ];
  12492.             return if ( $item_count < 1 );
  12493.         }
  12494.  
  12495.         #---------------------------------------------------------------
  12496.         # find lengths of all items in the list to calculate page layout
  12497.         #---------------------------------------------------------------
  12498.         my $comma_count = $item_count;
  12499.         my @item_lengths;
  12500.         my @i_term_begin;
  12501.         my @i_term_end;
  12502.         my @i_term_comma;
  12503.         my $i_prev_plus;
  12504.         my @max_length = ( 0, 0 );
  12505.         my $first_term_length;
  12506.         my $i      = $i_opening_paren;
  12507.         my $is_odd = 1;
  12508.  
  12509.         for ( my $j = 0 ; $j < $comma_count ; $j++ ) {
  12510.             $is_odd      = 1 - $is_odd;
  12511.             $i_prev_plus = $i + 1;
  12512.             $i           = $$rcomma_index[$j];
  12513.  
  12514.             my $i_term_end =
  12515.               ( $types_to_go[ $i - 1 ] eq 'b' ) ? $i - 2 : $i - 1;
  12516.             my $i_term_begin =
  12517.               ( $types_to_go[$i_prev_plus] eq 'b' )
  12518.               ? $i_prev_plus + 1
  12519.               : $i_prev_plus;
  12520.             push @i_term_begin, $i_term_begin;
  12521.             push @i_term_end,   $i_term_end;
  12522.             push @i_term_comma, $i;
  12523.  
  12524.             # note: currently adding 2 to all lengths (for comma and space)
  12525.             my $length =
  12526.               2 + token_sequence_length( $i_term_begin, $i_term_end );
  12527.             push @item_lengths, $length;
  12528.  
  12529.             if ( $j == 0 ) {
  12530.                 $first_term_length = $length;
  12531.             }
  12532.             else {
  12533.  
  12534.                 if ( $length > $max_length[$is_odd] ) {
  12535.                     $max_length[$is_odd] = $length;
  12536.                 }
  12537.             }
  12538.         }
  12539.  
  12540.         # now we have to make a distinction between the comma count and item
  12541.         # count, because the item count will be one greater than the comma
  12542.         # count if the last item is not terminated with a comma
  12543.         my $i_b =
  12544.           ( $types_to_go[ $i_last_comma + 1 ] eq 'b' )
  12545.           ? $i_last_comma + 1
  12546.           : $i_last_comma;
  12547.         my $i_e =
  12548.           ( $types_to_go[ $i_closing_paren - 1 ] eq 'b' )
  12549.           ? $i_closing_paren - 2
  12550.           : $i_closing_paren - 1;
  12551.         my $i_effective_last_comma = $i_last_comma;
  12552.  
  12553.         my $last_item_length = token_sequence_length( $i_b + 1, $i_e );
  12554.  
  12555.         if ( $last_item_length > 0 ) {
  12556.  
  12557.             # add 2 to length because other lengths include a comma and a blank
  12558.             $last_item_length += 2;
  12559.             push @item_lengths, $last_item_length;
  12560.             push @i_term_begin, $i_b + 1;
  12561.             push @i_term_end,   $i_e;
  12562.             push @i_term_comma, undef;
  12563.  
  12564.             my $i_odd = $item_count % 2;
  12565.  
  12566.             if ( $last_item_length > $max_length[$i_odd] ) {
  12567.                 $max_length[$i_odd] = $last_item_length;
  12568.             }
  12569.  
  12570.             $item_count++;
  12571.             $i_effective_last_comma = $i_e + 1;
  12572.  
  12573.             if ( $types_to_go[ $i_b + 1 ] =~ /^[iR\]]$/ ) {
  12574.                 $identifier_count++;
  12575.             }
  12576.         }
  12577.  
  12578.         #---------------------------------------------------------------
  12579.         # End of length calculations
  12580.         #---------------------------------------------------------------
  12581.  
  12582.         #---------------------------------------------------------------
  12583.         # Compound List Rule 1:
  12584.         # Break at (almost) every comma for a list containing a broken
  12585.         # sublist.  This has higher priority than the Interrupted List
  12586.         # Rule.
  12587.         #---------------------------------------------------------------
  12588.         if ( $has_broken_sublist[$depth] ) {
  12589.  
  12590.             # Break at every comma except for a comma between two
  12591.             # simple, small terms.  This prevents long vertical
  12592.             # columns of, say, just 0's.
  12593.             my $small_length = 10;    # 2 + actual maximum length wanted
  12594.  
  12595.             # We'll insert a break in long runs of small terms to
  12596.             # allow alignment in uniform tables.
  12597.             my $skipped_count = 0;
  12598.             my $columns       = table_columns_available($i_first_comma);
  12599.             my $fields        = int( $columns / $small_length );
  12600.             if (   $rOpts_maximum_fields_per_table
  12601.                 && $fields > $rOpts_maximum_fields_per_table )
  12602.             {
  12603.                 $fields = $rOpts_maximum_fields_per_table;
  12604.             }
  12605.             my $max_skipped_count = $fields - 1;
  12606.  
  12607.             my $is_simple_last_term = 0;
  12608.             my $is_simple_next_term = 0;
  12609.             foreach my $j ( 0 .. $item_count ) {
  12610.                 $is_simple_last_term = $is_simple_next_term;
  12611.                 $is_simple_next_term = 0;
  12612.                 if (   $j < $item_count
  12613.                     && $i_term_end[$j] == $i_term_begin[$j]
  12614.                     && $item_lengths[$j] <= $small_length )
  12615.                 {
  12616.                     $is_simple_next_term = 1;
  12617.                 }
  12618.                 next if $j == 0;
  12619.                 if (   $is_simple_last_term
  12620.                     && $is_simple_next_term
  12621.                     && $skipped_count < $max_skipped_count )
  12622.                 {
  12623.                     $skipped_count++;
  12624.                 }
  12625.                 else {
  12626.                     $skipped_count = 0;
  12627.                     my $i = $i_term_comma[ $j - 1 ];
  12628.                     last unless defined $i;
  12629.                     set_forced_breakpoint($i);
  12630.                 }
  12631.             }
  12632.  
  12633.             # always break at the last comma if this list is
  12634.             # interrupted; we wouldn't want to leave a terminal '{', for
  12635.             # example.
  12636.             if ($interrupted) { set_forced_breakpoint($i_true_last_comma) }
  12637.             return;
  12638.         }
  12639.  
  12640. #my ( $a, $b, $c ) = caller();
  12641. #print "LISTX: in set_list $a $c interupt=$interrupted count=$item_count
  12642. #i_first = $i_first_comma  i_last=$i_last_comma max=$max_index_to_go\n";
  12643. #print "depth=$depth has_broken=$has_broken_sublist[$depth] is_multi=$is_multiline opening_paren=($i_opening_paren) \n";
  12644.  
  12645.         #---------------------------------------------------------------
  12646.         # Interrupted List Rule:
  12647.         # A list is is forced to use old breakpoints if it was interrupted
  12648.         # by side comments or blank lines, or requested by user.
  12649.         #---------------------------------------------------------------
  12650.         if (   $rOpts_break_at_old_comma_breakpoints
  12651.             || $interrupted
  12652.             || $i_opening_paren < 0 )
  12653.         {
  12654.             copy_old_breakpoints( $i_first_comma, $i_true_last_comma );
  12655.             return;
  12656.         }
  12657.  
  12658.         #---------------------------------------------------------------
  12659.         # Looks like a list of items.  We have to look at it and size it up.
  12660.         #---------------------------------------------------------------
  12661.  
  12662.         my $opening_token       = $tokens_to_go[$i_opening_paren];
  12663.         my $opening_environment =
  12664.           $container_environment_to_go[$i_opening_paren];
  12665.  
  12666.         #-------------------------------------------------------------------
  12667.         # Return if this will fit on one line
  12668.         #-------------------------------------------------------------------
  12669.  
  12670.         my $i_opening_minus = find_token_starting_list($i_opening_paren);
  12671.         return
  12672.           unless excess_line_length( $i_opening_minus, $i_closing_paren ) > 0;
  12673.  
  12674.         #-------------------------------------------------------------------
  12675.         # Now we know that this block spans multiple lines; we have to set
  12676.         # at least one breakpoint -- real or fake -- as a signal to break
  12677.         # open any outer containers.
  12678.         #-------------------------------------------------------------------
  12679.         set_fake_breakpoint();
  12680.  
  12681.         # be sure we do not extend beyond the current list length
  12682.         if ( $i_effective_last_comma >= $max_index_to_go ) {
  12683.             $i_effective_last_comma = $max_index_to_go - 1;
  12684.         }
  12685.  
  12686.         # Set a flag indicating if we need to break open to keep -lp
  12687.         # items aligned.  This is necessary if any of the list terms
  12688.         # exceeds the available space after the '('.
  12689.         my $need_lp_break_open = $must_break_open;
  12690.         if ( $rOpts_line_up_parentheses && !$must_break_open ) {
  12691.             my $columns_if_unbroken = $rOpts_maximum_line_length -
  12692.               total_line_length( $i_opening_minus, $i_opening_paren );
  12693.             $need_lp_break_open = ( $max_length[0] > $columns_if_unbroken )
  12694.               || ( $max_length[1] > $columns_if_unbroken )
  12695.               || ( $first_term_length > $columns_if_unbroken );
  12696.         }
  12697.  
  12698.         # Specify if the list must have an even number of fields or not.
  12699.         # It is generally safest to assume an even number, because the
  12700.         # list items might be a hash list.  But if we can be sure that
  12701.         # it is not a hash, then we can allow an odd number for more
  12702.         # flexibility.
  12703.         my $odd_or_even = 2;    # 1 = odd field count ok, 2 = want even count
  12704.  
  12705.         if (   $identifier_count >= $item_count - 1
  12706.             || $next_nonblank_type eq '='
  12707.             || ( $list_type && $list_type ne '=>' && $list_type !~ /^[\:\?]$/ )
  12708.           )
  12709.         {
  12710.             $odd_or_even = 1;
  12711.         }
  12712.  
  12713.         # do we have a long first term which should be
  12714.         # left on a line by itself?
  12715.         my $use_separate_first_term = (
  12716.             $odd_or_even == 1       # only if we can use 1 field/line
  12717.               && $item_count > 3    # need several items
  12718.               && $first_term_length >
  12719.               2 * $max_length[0] - 2    # need long first term
  12720.               && $first_term_length >
  12721.               2 * $max_length[1] - 2    # need long first term
  12722.         );
  12723.  
  12724.         # or do we know from the type of list that the first term should
  12725.         # be placed alone?
  12726.         if ( !$use_separate_first_term ) {
  12727.             if ( $is_keyword_with_special_leading_term{$list_type} ) {
  12728.                 $use_separate_first_term = 1;
  12729.  
  12730.                 # should the container be broken open?
  12731.                 if ( $item_count < 3 ) {
  12732.                     if ( $i_first_comma - $i_opening_paren < 4 ) {
  12733.                         $$rdo_not_break_apart = 1;
  12734.                     }
  12735.                 }
  12736.                 elsif ($first_term_length < 20
  12737.                     && $i_first_comma - $i_opening_paren < 4 )
  12738.                 {
  12739.                     my $columns = table_columns_available($i_first_comma);
  12740.                     if ( $first_term_length < $columns ) {
  12741.                         $$rdo_not_break_apart = 1;
  12742.                     }
  12743.                 }
  12744.             }
  12745.         }
  12746.  
  12747.         # if so,
  12748.         if ($use_separate_first_term) {
  12749.  
  12750.             # ..set a break and update starting values
  12751.             $use_separate_first_term = 1;
  12752.             set_forced_breakpoint($i_first_comma);
  12753.             $i_opening_paren = $i_first_comma;
  12754.             $i_first_comma   = $$rcomma_index[1];
  12755.             $item_count--;
  12756.             return if $comma_count == 1;
  12757.             shift @item_lengths;
  12758.             shift @i_term_begin;
  12759.             shift @i_term_end;
  12760.             shift @i_term_comma;
  12761.         }
  12762.  
  12763.         # if not, update the metrics to include the first term
  12764.         else {
  12765.             if ( $first_term_length > $max_length[0] ) {
  12766.                 $max_length[0] = $first_term_length;
  12767.             }
  12768.         }
  12769.  
  12770.         # Field width parameters
  12771.         my $pair_width = ( $max_length[0] + $max_length[1] );
  12772.         my $max_width  =
  12773.           ( $max_length[0] > $max_length[1] ) ? $max_length[0] : $max_length[1];
  12774.  
  12775.         # Number of free columns across the page width for laying out tables
  12776.         my $columns = table_columns_available($i_first_comma);
  12777.  
  12778.         # Estimated maximum number of fields which fit this space
  12779.         # This will be our first guess
  12780.         my $number_of_fields_max =
  12781.           maximum_number_of_fields( $columns, $odd_or_even, $max_width,
  12782.             $pair_width );
  12783.         my $number_of_fields = $number_of_fields_max;
  12784.  
  12785.         # Find the best-looking number of fields
  12786.         # and make this our second guess if possible
  12787.         my ( $number_of_fields_best, $ri_ragged_break_list,
  12788.             $new_identifier_count )
  12789.           = study_list_complexity( \@i_term_begin, \@i_term_end, \@item_lengths,
  12790.             $max_width );
  12791.  
  12792.         if (   $number_of_fields_best != 0
  12793.             && $number_of_fields_best < $number_of_fields_max )
  12794.         {
  12795.             $number_of_fields = $number_of_fields_best;
  12796.         }
  12797.  
  12798.         # ----------------------------------------------------------------------
  12799.         # If we are crowded and the -lp option is being used, try to
  12800.         # undo some indentation
  12801.         # ----------------------------------------------------------------------
  12802.         if (
  12803.             $rOpts_line_up_parentheses
  12804.             && (
  12805.                 $number_of_fields == 0
  12806.                 || (   $number_of_fields == 1
  12807.                     && $number_of_fields != $number_of_fields_best )
  12808.             )
  12809.           )
  12810.         {
  12811.             my $available_spaces = get_AVAILABLE_SPACES_to_go($i_first_comma);
  12812.             if ( $available_spaces > 0 ) {
  12813.  
  12814.                 my $spaces_wanted = $max_width - $columns;    # for 1 field
  12815.  
  12816.                 if ( $number_of_fields_best == 0 ) {
  12817.                     $number_of_fields_best =
  12818.                       get_maximum_fields_wanted( \@item_lengths );
  12819.                 }
  12820.  
  12821.                 if ( $number_of_fields_best != 1 ) {
  12822.                     my $spaces_wanted_2 =
  12823.                       1 + $pair_width - $columns;             # for 2 fields
  12824.                     if ( $available_spaces > $spaces_wanted_2 ) {
  12825.                         $spaces_wanted = $spaces_wanted_2;
  12826.                     }
  12827.                 }
  12828.  
  12829.                 if ( $spaces_wanted > 0 ) {
  12830.                     my $deleted_spaces =
  12831.                       reduce_lp_indentation( $i_first_comma, $spaces_wanted );
  12832.  
  12833.                     # redo the math
  12834.                     if ( $deleted_spaces > 0 ) {
  12835.                         $columns = table_columns_available($i_first_comma);
  12836.                         $number_of_fields_max =
  12837.                           maximum_number_of_fields( $columns, $odd_or_even,
  12838.                             $max_width, $pair_width );
  12839.                         $number_of_fields = $number_of_fields_max;
  12840.  
  12841.                         if (   $number_of_fields_best == 1
  12842.                             && $number_of_fields >= 1 )
  12843.                         {
  12844.                             $number_of_fields = $number_of_fields_best;
  12845.                         }
  12846.                     }
  12847.                 }
  12848.             }
  12849.         }
  12850.  
  12851.         # try for one column if two won't work
  12852.         if ( $number_of_fields <= 0 ) {
  12853.             $number_of_fields = int( $columns / $max_width );
  12854.         }
  12855.  
  12856.         # The user can place an upper bound on the number of fields,
  12857.         # which can be useful for doing maintenance on tables
  12858.         if (   $rOpts_maximum_fields_per_table
  12859.             && $number_of_fields > $rOpts_maximum_fields_per_table )
  12860.         {
  12861.             $number_of_fields = $rOpts_maximum_fields_per_table;
  12862.         }
  12863.  
  12864.         # How many columns (characters) and lines would this container take
  12865.         # if no additional whitespace were added?
  12866.         my $packed_columns = token_sequence_length( $i_opening_paren + 1,
  12867.             $i_effective_last_comma + 1 );
  12868.         if ( $columns <= 0 ) { $columns = 1 }    # avoid divide by zero
  12869.         my $packed_lines = 1 + int( $packed_columns / $columns );
  12870.  
  12871.         # are we an item contained in an outer list?
  12872.         my $in_hierarchical_list = $next_nonblank_type =~ /^[\}\,]$/;
  12873.  
  12874.         if ( $number_of_fields <= 0 ) {
  12875.  
  12876. #         #---------------------------------------------------------------
  12877. #         # We're in trouble.  We can't find a single field width that works.
  12878. #         # There is no simple answer here; we may have a single long list
  12879. #         # item, or many.
  12880. #         #---------------------------------------------------------------
  12881. #
  12882. #         In many cases, it may be best to not force a break if there is just one
  12883. #         comma, because the standard continuation break logic will do a better
  12884. #         job without it.
  12885. #
  12886. #         In the common case that all but one of the terms can fit
  12887. #         on a single line, it may look better not to break open the
  12888. #         containing parens.  Consider, for example
  12889. #
  12890. #             $color =
  12891. #               join ( '/',
  12892. #                 sort { $color_value{$::a} <=> $color_value{$::b}; }
  12893. #                 keys %colors );
  12894. #
  12895. #         which will look like this with the container broken:
  12896. #
  12897. #             $color = join (
  12898. #                 '/',
  12899. #                 sort { $color_value{$::a} <=> $color_value{$::b}; } keys %colors
  12900. #             );
  12901. #
  12902. #         Here is an example of this rule for a long last term:
  12903. #
  12904. #             log_message( 0, 256, 128,
  12905. #                 "Number of routes in adj-RIB-in to be considered: $peercount" );
  12906. #
  12907. #         And here is an example with a long first term:
  12908. #
  12909. #         $s = sprintf(
  12910. # "%2d wallclock secs (%$f usr %$f sys + %$f cusr %$f csys = %$f CPU)",
  12911. #             $r, $pu, $ps, $cu, $cs, $tt
  12912. #           )
  12913. #           if $style eq 'all';
  12914.  
  12915.             my $i_last_comma    = $$rcomma_index[ $comma_count - 1 ];
  12916.             my $long_last_term  = excess_line_length( 0, $i_last_comma ) <= 0;
  12917.             my $long_first_term =
  12918.               excess_line_length( $i_first_comma + 1, $max_index_to_go ) <= 0;
  12919.  
  12920.             # break at every comma ...
  12921.             if (
  12922.  
  12923.                 # if requested by user or is best looking
  12924.                 $number_of_fields_best == 1
  12925.  
  12926.                 # or if this is a sublist of a larger list
  12927.                 || $in_hierarchical_list
  12928.  
  12929.                 # or if multiple commas and we dont have a long first or last
  12930.                 # term
  12931.                 || ( $comma_count > 1
  12932.                     && !( $long_last_term || $long_first_term ) )
  12933.               )
  12934.             {
  12935.                 foreach ( 0 .. $comma_count - 1 ) {
  12936.                     set_forced_breakpoint( $$rcomma_index[$_] );
  12937.                 }
  12938.             }
  12939.             elsif ($long_last_term) {
  12940.  
  12941.                 set_forced_breakpoint($i_last_comma);
  12942.                 $$rdo_not_break_apart = 1 unless $must_break_open;
  12943.             }
  12944.             elsif ($long_first_term) {
  12945.  
  12946.                 set_forced_breakpoint($i_first_comma);
  12947.             }
  12948.             else {
  12949.  
  12950.                 # let breaks be defined by default bond strength logic
  12951.             }
  12952.             return;
  12953.         }
  12954.  
  12955.         # --------------------------------------------------------
  12956.         # We have a tentative field count that seems to work.
  12957.         # How many lines will this require?
  12958.         # --------------------------------------------------------
  12959.         my $formatted_lines = $item_count / ($number_of_fields);
  12960.         if ( $formatted_lines != int $formatted_lines ) {
  12961.             $formatted_lines = 1 + int $formatted_lines;
  12962.         }
  12963.  
  12964.         # So far we've been trying to fill out to the right margin.  But
  12965.         # compact tables are easier to read, so let's see if we can use fewer
  12966.         # fields without increasing the number of lines.
  12967.         $number_of_fields =
  12968.           compactify_table( $item_count, $number_of_fields, $formatted_lines,
  12969.             $odd_or_even );
  12970.  
  12971.         # How many spaces across the page will we fill?
  12972.         my $columns_per_line =
  12973.           ( int $number_of_fields / 2 ) * $pair_width +
  12974.           ( $number_of_fields % 2 ) * $max_width;
  12975.  
  12976.         my $formatted_columns;
  12977.  
  12978.         if ( $number_of_fields > 1 ) {
  12979.             $formatted_columns =
  12980.               ( $pair_width * ( int( $item_count / 2 ) ) + ( $item_count % 2 ) *
  12981.                   $max_width );
  12982.         }
  12983.         else {
  12984.             $formatted_columns = $max_width * $item_count;
  12985.         }
  12986.         if ( $formatted_columns < $packed_columns ) {
  12987.             $formatted_columns = $packed_columns;
  12988.         }
  12989.  
  12990.         my $unused_columns = $formatted_columns - $packed_columns;
  12991.  
  12992.         # set some empirical parameters to help decide if we should try to
  12993.         # align; high sparsity does not look good, especially with few lines
  12994.         my $sparsity = ($unused_columns) / ($formatted_columns);
  12995.         my $max_allowed_sparsity =
  12996.           ( $item_count < 3 ) ? 0.1
  12997.           : ( $packed_lines == 1 ) ? 0.15
  12998.           : ( $packed_lines == 2 ) ? 0.4
  12999.           : 0.7;
  13000.  
  13001.         # Begin check for shortcut methods, which avoid treating a list
  13002.         # as a table for relatively small parenthesized lists.  These
  13003.         # are usually easier to read if not formatted as tables.
  13004.         if (
  13005.             $packed_lines <= 2    # probably can fit in 2 lines
  13006.             && $item_count < 9    # doesn't have too many items
  13007.             && $opening_environment eq 'BLOCK'    # not a sub-container
  13008.             && $opening_token       eq '('        # is paren list
  13009.           )
  13010.         {
  13011.  
  13012.             # Shortcut method 1: for -lp and just one comma:
  13013.             # This is a no-brainer, just break at the comma.
  13014.             if (
  13015.                 $rOpts_line_up_parentheses        # -lp
  13016.                 && $item_count == 2               # two items, one comma
  13017.                 && !$must_break_open
  13018.               )
  13019.             {
  13020.                 my $i_break = $$rcomma_index[0];
  13021.                 set_forced_breakpoint($i_break);
  13022.                 $$rdo_not_break_apart = 1;
  13023.                 set_non_alignment_flags( $comma_count, $rcomma_index );
  13024.                 return;
  13025.  
  13026.             }
  13027.  
  13028.             # method 2 is for most small ragged lists which might look
  13029.             # best if not displayed as a table.
  13030.             if (
  13031.                 ( $number_of_fields == 2 && $item_count == 3 )
  13032.                 || (
  13033.                     $new_identifier_count > 0    # isn't all quotes
  13034.                     && $sparsity > 0.15
  13035.                 )    # would be fairly spaced gaps if aligned
  13036.               )
  13037.             {
  13038.  
  13039.                 my $break_count =
  13040.                   set_ragged_breakpoints( \@i_term_comma,
  13041.                     $ri_ragged_break_list );
  13042.                 ++$break_count if ($use_separate_first_term);
  13043.  
  13044.                 # NOTE: we should really use the true break count here,
  13045.                 # which can be greater if there are large terms and
  13046.                 # little space, but usually this will work well enough.
  13047.                 unless ($must_break_open) {
  13048.  
  13049.                     if ( $break_count <= 1 ) {
  13050.                         $$rdo_not_break_apart = 1;
  13051.                     }
  13052.                     elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
  13053.                     {
  13054.                         $$rdo_not_break_apart = 1;
  13055.                     }
  13056.                 }
  13057.                 set_non_alignment_flags( $comma_count, $rcomma_index );
  13058.                 return;
  13059.             }
  13060.  
  13061.         }    # end shortcut methods
  13062.  
  13063.         # debug stuff
  13064.  
  13065.         FORMATTER_DEBUG_FLAG_SPARSE && do {
  13066.             print
  13067. "SPARSE:cols=$columns commas=$comma_count items:$item_count ids=$identifier_count pairwidth=$pair_width fields=$number_of_fields lines packed: $packed_lines packed_cols=$packed_columns fmtd:$formatted_lines cols /line:$columns_per_line  unused:$unused_columns fmtd:$formatted_columns sparsity=$sparsity allow=$max_allowed_sparsity\n";
  13068.  
  13069.         };
  13070.  
  13071.         #---------------------------------------------------------------
  13072.         # Compound List Rule 2:
  13073.         # If this list is too long for one line, and it is an item of a
  13074.         # larger list, then we must format it, regardless of sparsity
  13075.         # (ian.t).  One reason that we have to do this is to trigger
  13076.         # Compound List Rule 1, above, which causes breaks at all commas of
  13077.         # all outer lists.  In this way, the structure will be properly
  13078.         # displayed.
  13079.         #---------------------------------------------------------------
  13080.  
  13081.         # Decide if this list is too long for one line unless broken
  13082.         my $total_columns = table_columns_available($i_opening_paren);
  13083.         my $too_long      = $packed_columns > $total_columns;
  13084.  
  13085.         # For a paren list, include the length of the token just before the
  13086.         # '(' because this is likely a sub call, and we would have to
  13087.         # include the sub name on the same line as the list.  This is still
  13088.         # imprecise, but not too bad.  (steve.t)
  13089.         if ( !$too_long && $i_opening_paren > 0 && $opening_token eq '(' ) {
  13090.  
  13091.             $too_long =
  13092.               excess_line_length( $i_opening_minus,
  13093.                 $i_effective_last_comma + 1 ) > 0;
  13094.         }
  13095.  
  13096.         # FIXME: For an item after a '=>', try to include the length of the
  13097.         # thing before the '=>'.  This is crude and should be improved by
  13098.         # actually looking back token by token.
  13099.         if ( !$too_long && $i_opening_paren > 0 && $list_type eq '=>' ) {
  13100.             my $i_opening_minus = $i_opening_paren - 4;
  13101.             if ( $i_opening_minus >= 0 ) {
  13102.                 $too_long =
  13103.                   excess_line_length( $i_opening_minus,
  13104.                     $i_effective_last_comma + 1 ) > 0;
  13105.             }
  13106.         }
  13107.  
  13108.         # Always break lists contained in '[' and '{' if too long for 1 line,
  13109.         # and always break lists which are too long and part of a more complex
  13110.         # structure.
  13111.         my $must_break_open_container = $must_break_open
  13112.           || ( $too_long
  13113.             && ( $in_hierarchical_list || $opening_token ne '(' ) );
  13114.  
  13115. #print "LISTX: next=$next_nonblank_type  avail cols=$columns packed=$packed_columns must format = $must_break_open_container too-long=$too_long  opening=$opening_token list_type=$list_type formatted_lines=$formatted_lines  packed=$packed_lines max_sparsity= $max_allowed_sparsity sparsity=$sparsity \n";
  13116.  
  13117.         #---------------------------------------------------------------
  13118.         # The main decision:
  13119.         # Now decide if we will align the data into aligned columns.  Do not
  13120.         # attempt to align columns if this is a tiny table or it would be
  13121.         # too spaced.  It seems that the more packed lines we have, the
  13122.         # sparser the list that can be allowed and still look ok.
  13123.         #---------------------------------------------------------------
  13124.  
  13125.         if (   ( $formatted_lines < 3 && $packed_lines < $formatted_lines )
  13126.             || ( $formatted_lines < 2 )
  13127.             || ( $unused_columns > $max_allowed_sparsity * $formatted_columns )
  13128.           )
  13129.         {
  13130.  
  13131.             #---------------------------------------------------------------
  13132.             # too sparse: would look ugly if aligned in a table;
  13133.             #---------------------------------------------------------------
  13134.  
  13135.             # use old breakpoints if this is a 'big' list
  13136.             # FIXME: goal is to improve set_ragged_breakpoints so that
  13137.             # this is not necessary.
  13138.             if ( $packed_lines > 2 && $item_count > 10 ) {
  13139.                 write_logfile_entry("List sparse: using old breakpoints\n");
  13140.                 copy_old_breakpoints( $i_first_comma, $i_last_comma );
  13141.             }
  13142.  
  13143.             # let the continuation logic handle it if 2 lines
  13144.             else {
  13145.  
  13146.                 my $break_count =
  13147.                   set_ragged_breakpoints( \@i_term_comma,
  13148.                     $ri_ragged_break_list );
  13149.                 ++$break_count if ($use_separate_first_term);
  13150.  
  13151.                 unless ($must_break_open_container) {
  13152.                     if ( $break_count <= 1 ) {
  13153.                         $$rdo_not_break_apart = 1;
  13154.                     }
  13155.                     elsif ( $rOpts_line_up_parentheses && !$need_lp_break_open )
  13156.                     {
  13157.                         $$rdo_not_break_apart = 1;
  13158.                     }
  13159.                 }
  13160.                 set_non_alignment_flags( $comma_count, $rcomma_index );
  13161.             }
  13162.             return;
  13163.         }
  13164.  
  13165.         #---------------------------------------------------------------
  13166.         # go ahead and format as a table
  13167.         #---------------------------------------------------------------
  13168.         write_logfile_entry(
  13169.             "List: auto formatting with $number_of_fields fields/row\n");
  13170.  
  13171.         my $j_first_break =
  13172.           $use_separate_first_term ? $number_of_fields : $number_of_fields - 1;
  13173.  
  13174.         for (
  13175.             my $j = $j_first_break ;
  13176.             $j < $comma_count ;
  13177.             $j += $number_of_fields
  13178.           )
  13179.         {
  13180.             my $i = $$rcomma_index[$j];
  13181.             set_forced_breakpoint($i);
  13182.         }
  13183.         return;
  13184.     }
  13185. }
  13186.  
  13187. sub set_non_alignment_flags {
  13188.  
  13189.     # set flag which indicates that these commas should not be
  13190.     # aligned
  13191.     my ( $comma_count, $rcomma_index ) = @_;
  13192.     foreach ( 0 .. $comma_count - 1 ) {
  13193.         $matching_token_to_go[ $$rcomma_index[$_] ] = 1;
  13194.     }
  13195. }
  13196.  
  13197. sub study_list_complexity {
  13198.  
  13199.     # Look for complex tables which should be formatted with one term per line.
  13200.     # Returns the following:
  13201.     #
  13202.     #  \@i_ragged_break_list = list of good breakpoints to avoid lines
  13203.     #    which are hard to read
  13204.     #  $number_of_fields_best = suggested number of fields based on
  13205.     #    complexity; = 0 if any number may be used.
  13206.     #
  13207.     my ( $ri_term_begin, $ri_term_end, $ritem_lengths, $max_width ) = @_;
  13208.     my $item_count            = @{$ri_term_begin};
  13209.     my $complex_item_count    = 0;
  13210.     my $number_of_fields_best = $rOpts_maximum_fields_per_table;
  13211.     my $i_max                 = @{$ritem_lengths} - 1;
  13212.     ##my @item_complexity;
  13213.  
  13214.     my $i_last_last_break = -3;
  13215.     my $i_last_break      = -2;
  13216.     my @i_ragged_break_list;
  13217.  
  13218.     my $definitely_complex = 30;
  13219.     my $definitely_simple  = 12;
  13220.     my $quote_count        = 0;
  13221.  
  13222.     for my $i ( 0 .. $i_max ) {
  13223.         my $ib = $ri_term_begin->[$i];
  13224.         my $ie = $ri_term_end->[$i];
  13225.  
  13226.         # define complexity: start with the actual term length
  13227.         my $weighted_length = ( $ritem_lengths->[$i] - 2 );
  13228.  
  13229.         ##TBD: join types here and check for variations
  13230.         ##my $str=join "", @tokens_to_go[$ib..$ie];
  13231.  
  13232.         my $is_quote = 0;
  13233.         if ( $types_to_go[$ib] =~ /^[qQ]$/ ) {
  13234.             $is_quote = 1;
  13235.             $quote_count++;
  13236.         }
  13237.         elsif ( $types_to_go[$ib] =~ /^[w\-]$/ ) {
  13238.             $quote_count++;
  13239.         }
  13240.  
  13241.         if ( $ib eq $ie ) {
  13242.             if ( $is_quote && $tokens_to_go[$ib] =~ /\s/ ) {
  13243.                 $complex_item_count++;
  13244.                 $weighted_length *= 2;
  13245.             }
  13246.             else {
  13247.             }
  13248.         }
  13249.         else {
  13250.             if ( grep { $_ eq 'b' } @types_to_go[ $ib .. $ie ] ) {
  13251.                 $complex_item_count++;
  13252.                 $weighted_length *= 2;
  13253.             }
  13254.             if ( grep { $_ eq '..' } @types_to_go[ $ib .. $ie ] ) {
  13255.                 $weighted_length += 4;
  13256.             }
  13257.         }
  13258.  
  13259.         # add weight for extra tokens.
  13260.         $weighted_length += 2 * ( $ie - $ib );
  13261.  
  13262. ##        my $BUB = join '', @tokens_to_go[$ib..$ie];
  13263. ##        print "# COMPLEXITY:$weighted_length   $BUB\n";
  13264.  
  13265. ##push @item_complexity, $weighted_length;
  13266.  
  13267.         # now mark a ragged break after this item it if it is 'long and
  13268.         # complex':
  13269.         if ( $weighted_length >= $definitely_complex ) {
  13270.  
  13271.             # if we broke after the previous term
  13272.             # then break before it too
  13273.             if (   $i_last_break == $i - 1
  13274.                 && $i > 1
  13275.                 && $i_last_last_break != $i - 2 )
  13276.             {
  13277.  
  13278.                 ## FIXME: don't strand a small term
  13279.                 pop @i_ragged_break_list;
  13280.                 push @i_ragged_break_list, $i - 2;
  13281.                 push @i_ragged_break_list, $i - 1;
  13282.             }
  13283.  
  13284.             push @i_ragged_break_list, $i;
  13285.             $i_last_last_break = $i_last_break;
  13286.             $i_last_break      = $i;
  13287.         }
  13288.  
  13289.         # don't break before a small last term -- it will
  13290.         # not look good on a line by itself.
  13291.         elsif ($i == $i_max
  13292.             && $i_last_break == $i - 1
  13293.             && $weighted_length <= $definitely_simple )
  13294.         {
  13295.             pop @i_ragged_break_list;
  13296.         }
  13297.     }
  13298.  
  13299.     my $identifier_count = $i_max + 1 - $quote_count;
  13300.  
  13301.     # Need more tuning here..
  13302.     if (   $max_width > 12
  13303.         && $complex_item_count > $item_count / 2
  13304.         && $number_of_fields_best != 2 )
  13305.     {
  13306.         $number_of_fields_best = 1;
  13307.     }
  13308.  
  13309.     return ( $number_of_fields_best, \@i_ragged_break_list, $identifier_count );
  13310. }
  13311.  
  13312. sub get_maximum_fields_wanted {
  13313.  
  13314.     # Not all tables look good with more than one field of items.
  13315.     # This routine looks at a table and decides if it should be
  13316.     # formatted with just one field or not.
  13317.     # This coding is still under development.
  13318.     my ($ritem_lengths) = @_;
  13319.  
  13320.     my $number_of_fields_best = 0;
  13321.  
  13322.     # For just a few items, we tentatively assume just 1 field.
  13323.     my $item_count = @{$ritem_lengths};
  13324.     if ( $item_count <= 5 ) {
  13325.         $number_of_fields_best = 1;
  13326.     }
  13327.  
  13328.     # For larger tables, look at it both ways and see what looks best
  13329.     else {
  13330.  
  13331.         my $is_odd            = 1;
  13332.         my @max_length        = ( 0, 0 );
  13333.         my @last_length_2     = ( undef, undef );
  13334.         my @first_length_2    = ( undef, undef );
  13335.         my $last_length       = undef;
  13336.         my $total_variation_1 = 0;
  13337.         my $total_variation_2 = 0;
  13338.         my @total_variation_2 = ( 0, 0 );
  13339.         for ( my $j = 0 ; $j < $item_count ; $j++ ) {
  13340.  
  13341.             $is_odd = 1 - $is_odd;
  13342.             my $length = $ritem_lengths->[$j];
  13343.             if ( $length > $max_length[$is_odd] ) {
  13344.                 $max_length[$is_odd] = $length;
  13345.             }
  13346.  
  13347.             if ( defined($last_length) ) {
  13348.                 my $dl = abs( $length - $last_length );
  13349.                 $total_variation_1 += $dl;
  13350.             }
  13351.             $last_length = $length;
  13352.  
  13353.             my $ll = $last_length_2[$is_odd];
  13354.             if ( defined($ll) ) {
  13355.                 my $dl = abs( $length - $ll );
  13356.                 $total_variation_2[$is_odd] += $dl;
  13357.             }
  13358.             else {
  13359.                 $first_length_2[$is_odd] = $length;
  13360.             }
  13361.             $last_length_2[$is_odd] = $length;
  13362.         }
  13363.         $total_variation_2 = $total_variation_2[0] + $total_variation_2[1];
  13364.  
  13365.         my $factor = ( $item_count > 10 ) ? 1 : ( $item_count > 5 ) ? 0.75 : 0;
  13366.         unless ( $total_variation_2 < $factor * $total_variation_1 ) {
  13367.             $number_of_fields_best = 1;
  13368.         }
  13369.     }
  13370.     return ($number_of_fields_best);
  13371. }
  13372.  
  13373. sub table_columns_available {
  13374.     my $i_first_comma = shift;
  13375.     my $columns       =
  13376.       $rOpts_maximum_line_length - leading_spaces_to_go($i_first_comma);
  13377.  
  13378.     # Patch: the vertical formatter does not line up lines whose lengths
  13379.     # exactly equal the available line length because of allowances
  13380.     # that must be made for side comments.  Therefore, the number of
  13381.     # available columns is reduced by 1 character.
  13382.     $columns -= 1;
  13383.     return $columns;
  13384. }
  13385.  
  13386. sub maximum_number_of_fields {
  13387.  
  13388.     # how many fields will fit in the available space?
  13389.     my ( $columns, $odd_or_even, $max_width, $pair_width ) = @_;
  13390.     my $max_pairs        = int( $columns / $pair_width );
  13391.     my $number_of_fields = $max_pairs * 2;
  13392.     if (   $odd_or_even == 1
  13393.         && $max_pairs * $pair_width + $max_width <= $columns )
  13394.     {
  13395.         $number_of_fields++;
  13396.     }
  13397.     return $number_of_fields;
  13398. }
  13399.  
  13400. sub compactify_table {
  13401.  
  13402.     # given a table with a certain number of fields and a certain number
  13403.     # of lines, see if reducing the number of fields will make it look
  13404.     # better.
  13405.     my ( $item_count, $number_of_fields, $formatted_lines, $odd_or_even ) = @_;
  13406.     if ( $number_of_fields >= $odd_or_even * 2 && $formatted_lines > 0 ) {
  13407.         my $min_fields;
  13408.  
  13409.         for (
  13410.             $min_fields = $number_of_fields ;
  13411.             $min_fields >= $odd_or_even
  13412.             && $min_fields * $formatted_lines >= $item_count ;
  13413.             $min_fields -= $odd_or_even
  13414.           )
  13415.         {
  13416.             $number_of_fields = $min_fields;
  13417.         }
  13418.     }
  13419.     return $number_of_fields;
  13420. }
  13421.  
  13422. sub set_ragged_breakpoints {
  13423.  
  13424.     # Set breakpoints in a list that cannot be formatted nicely as a
  13425.     # table.
  13426.     my ( $ri_term_comma, $ri_ragged_break_list ) = @_;
  13427.  
  13428.     my $break_count = 0;
  13429.     foreach (@$ri_ragged_break_list) {
  13430.         my $j = $ri_term_comma->[$_];
  13431.         if ($j) {
  13432.             set_forced_breakpoint($j);
  13433.             $break_count++;
  13434.         }
  13435.     }
  13436.     return $break_count;
  13437. }
  13438.  
  13439. sub copy_old_breakpoints {
  13440.     my ( $i_first_comma, $i_last_comma ) = @_;
  13441.     for my $i ( $i_first_comma .. $i_last_comma ) {
  13442.         if ( $old_breakpoint_to_go[$i] ) {
  13443.             set_forced_breakpoint($i);
  13444.         }
  13445.     }
  13446. }
  13447.  
  13448. sub set_nobreaks {
  13449.     my ( $i, $j ) = @_;
  13450.     if ( $i >= 0 && $i <= $j && $j <= $max_index_to_go ) {
  13451.  
  13452.         FORMATTER_DEBUG_FLAG_NOBREAK && do {
  13453.             my ( $a, $b, $c ) = caller();
  13454.             print(
  13455. "NOBREAK: forced_breakpoint $forced_breakpoint_count from $a $c with i=$i max=$max_index_to_go type=$types_to_go[$i]\n"
  13456.             );
  13457.         };
  13458.  
  13459.         @nobreak_to_go[ $i .. $j ] = (1) x ( $j - $i + 1 );
  13460.     }
  13461.  
  13462.     # shouldn't happen; non-critical error
  13463.     else {
  13464.         FORMATTER_DEBUG_FLAG_NOBREAK && do {
  13465.             my ( $a, $b, $c ) = caller();
  13466.             print(
  13467. "NOBREAK ERROR: from $a $c with i=$i j=$j max=$max_index_to_go\n"
  13468.             );
  13469.         };
  13470.     }
  13471. }
  13472.  
  13473. sub set_fake_breakpoint {
  13474.  
  13475.     # Just bump up the breakpoint count as a signal that there are breaks.
  13476.     # This is useful if we have breaks but may want to postpone deciding where
  13477.     # to make them.
  13478.     $forced_breakpoint_count++;
  13479. }
  13480.  
  13481. sub set_forced_breakpoint {
  13482.     my $i = shift;
  13483.  
  13484.     return unless defined $i && $i >= 0;
  13485.  
  13486.     # when called with certain tokens, use bond strengths to decide
  13487.     # if we break before or after it
  13488.     my $token = $tokens_to_go[$i];
  13489.     if ( $token =~ /^([\.\,\:\?]|&&|\|\|)$/ ) {
  13490.         if ( $want_break_before{$token} && $i >= 0 ) { $i-- }
  13491.     }
  13492.  
  13493.     # breaks are forced before 'or' and 'and' for now:
  13494.     if ( $is_if_unless_and_or{$token} ) { $i-- }
  13495.  
  13496.     if ( $i >= 0 && $i <= $max_index_to_go ) {
  13497.         my $i_nonblank = ( $types_to_go[$i] ne 'b' ) ? $i : $i - 1;
  13498.  
  13499.         FORMATTER_DEBUG_FLAG_FORCE && do {
  13500.             my ( $a, $b, $c ) = caller();
  13501.             print
  13502. "FORCE forced_breakpoint $forced_breakpoint_count from $a $c with i=$i_nonblank max=$max_index_to_go tok=$tokens_to_go[$i_nonblank] type=$types_to_go[$i_nonblank] nobr=$nobreak_to_go[$i_nonblank]\n";
  13503.         };
  13504.  
  13505.         if ( $i_nonblank >= 0 && $nobreak_to_go[$i_nonblank] == 0 ) {
  13506.             $forced_breakpoint_to_go[$i_nonblank] = 1;
  13507.  
  13508.             if ( $i_nonblank > $index_max_forced_break ) {
  13509.                 $index_max_forced_break = $i_nonblank;
  13510.             }
  13511.             $forced_breakpoint_count++;
  13512.             $forced_breakpoint_undo_stack[ $forced_breakpoint_undo_count++ ] =
  13513.               $i_nonblank;
  13514.  
  13515.             # if we break at an opening container..break at the closing
  13516.             if ( $tokens_to_go[$i_nonblank] =~ /^[\{\[\(\?]$/ ) {
  13517.                 set_closing_breakpoint($i_nonblank);
  13518.             }
  13519.         }
  13520.     }
  13521. }
  13522.  
  13523. sub clear_breakpoint_undo_stack {
  13524.     $forced_breakpoint_undo_count = 0;
  13525. }
  13526.  
  13527. sub undo_forced_breakpoint_stack {
  13528.  
  13529.     my $i_start = shift;
  13530.     if ( $i_start < 0 ) {
  13531.         $i_start = 0;
  13532.         my ( $a, $b, $c ) = caller();
  13533.         warning(
  13534. "Program Bug: undo_forced_breakpoint_stack from $a $c has i=$i_start "
  13535.         );
  13536.     }
  13537.  
  13538.     while ( $forced_breakpoint_undo_count > $i_start ) {
  13539.         my $i =
  13540.           $forced_breakpoint_undo_stack[ --$forced_breakpoint_undo_count ];
  13541.         if ( $i >= 0 && $i <= $max_index_to_go ) {
  13542.             $forced_breakpoint_to_go[$i] = 0;
  13543.             $forced_breakpoint_count--;
  13544.  
  13545.             FORMATTER_DEBUG_FLAG_UNDOBP && do {
  13546.                 my ( $a, $b, $c ) = caller();
  13547.                 print(
  13548. "UNDOBP: undo forced_breakpoint i=$i $forced_breakpoint_undo_count from $a $c max=$max_index_to_go\n"
  13549.                 );
  13550.             };
  13551.         }
  13552.  
  13553.         # shouldn't happen, but not a critical error
  13554.         else {
  13555.             FORMATTER_DEBUG_FLAG_UNDOBP && do {
  13556.                 my ( $a, $b, $c ) = caller();
  13557.                 print(
  13558. "Program Bug: undo_forced_breakpoint from $a $c has i=$i but max=$max_index_to_go"
  13559.                 );
  13560.             };
  13561.         }
  13562.     }
  13563. }
  13564.  
  13565. {    # begin recombine_breakpoints
  13566.     my %is_last_next_redo_return;
  13567.     my %is_if_unless;
  13568.     my %is_and_or;
  13569.  
  13570.     BEGIN {
  13571.         @_ = qw(last next redo return);
  13572.         @is_last_next_redo_return{@_} = (1) x scalar(@_);
  13573.  
  13574.         @_ = qw(if unless);
  13575.         @is_if_unless{@_} = (1) x scalar(@_);
  13576.  
  13577.         @_ = qw(and or);
  13578.         @is_and_or{@_} = (1) x scalar(@_);
  13579.     }
  13580.  
  13581.     sub recombine_breakpoints {
  13582.  
  13583.         # sub set_continuation_breaks is very liberal in setting line breaks
  13584.         # for long lines, always setting breaks at good breakpoints, even
  13585.         # when that creates small lines.  Occasionally small line fragments
  13586.         # are produced which would look better if they were combined.
  13587.         # That's the task of this routine, recombine_breakpoints.
  13588.         my ( $ri_first, $ri_last ) = @_;
  13589.         my $more_to_do = 1;
  13590.  
  13591.         # Keep looping until there are no more possible recombinations
  13592.         my $nmax_last = @$ri_last;
  13593.         while ($more_to_do) {
  13594.             my $n_best = 0;
  13595.             my $bs_best;
  13596.             my $n;
  13597.             my $nmax = @$ri_last - 1;
  13598.  
  13599.             # safety check..
  13600.             unless ( $nmax < $nmax_last ) {
  13601.  
  13602.             # shouldn't happen because splice below decreases nmax on each pass:
  13603.             # but i get paranoid sometimes
  13604.                 die "Program bug-infinite loop in recombine breakpoints\n";
  13605.             }
  13606.             $nmax_last  = $nmax;
  13607.             $more_to_do = 0;
  13608.  
  13609.             # loop over all remaining lines...
  13610.             for $n ( 1 .. $nmax ) {
  13611.  
  13612.                 #----------------------------------------------------------
  13613.                 # Indexes of the endpoints of the two lines are:
  13614.                 #
  13615.                 #  ---left---- | ---right---
  13616.                 #  $if   $imid | $imidr   $il
  13617.                 #
  13618.                 # We want to decide if we should join tokens $imid to $imidr
  13619.                 #----------------------------------------------------------
  13620.                 my $if    = $$ri_first[ $n - 1 ];
  13621.                 my $il    = $$ri_last[$n];
  13622.                 my $imid  = $$ri_last[ $n - 1 ];
  13623.                 my $imidr = $$ri_first[$n];
  13624.  
  13625. #print "RECOMBINE: n=$n imid=$imid if=$if type=$types_to_go[$if] =$tokens_to_go[$if] next_type=$types_to_go[$imidr] next_tok=$tokens_to_go[$imidr]\n";
  13626.  
  13627.                 #----------------------------------------------------------
  13628.                 # Start of special recombination rules
  13629.                 # These are ad-hoc rules which have been found to work ok.
  13630.                 # Skip to next pair to avoid re-combination.
  13631.                 #----------------------------------------------------------
  13632.  
  13633.                 # a terminal '{' should stay where it is
  13634.                 next if ( $n == $nmax && $types_to_go[$imidr] eq '{' );
  13635.  
  13636.                 #----------------------------------------------------------
  13637.                 # examine token at $imid  (right end of first line of pair)
  13638.                 #----------------------------------------------------------
  13639.  
  13640.                 # an isolated '}' may join with a ';' terminated segment
  13641.                 if ( $types_to_go[$imid] eq '}' ) {
  13642.                     next
  13643.                       unless (
  13644.  
  13645.                         # join } and ;
  13646.                         ( ( $if == $imid ) && ( $types_to_go[$il] eq ';' ) )
  13647.  
  13648.                         # handle '.' and '?' below
  13649.                         || ( $types_to_go[$imidr] =~ /^[\.\?]$/ )
  13650.                       );
  13651.                 }
  13652.  
  13653.                 # for lines ending in a comma...
  13654.                 elsif ( $types_to_go[$imid] eq ',' ) {
  13655.  
  13656.                  # an isolated '},' may join with an identifier + ';'
  13657.                  # this is useful for the class of a 'bless' statement (bless.t)
  13658.                     if (   $types_to_go[$if] eq '}'
  13659.                         && $types_to_go[$imidr] eq 'i' )
  13660.                     {
  13661.                         next
  13662.                           unless ( ( $if == ( $imid - 1 ) )
  13663.                             && ( $il == ( $imidr + 1 ) )
  13664.                             && ( $types_to_go[$il] eq ';' ) );
  13665.  
  13666.                         # override breakpoint
  13667.                         $forced_breakpoint_to_go[$imid] = 0;
  13668.                     }
  13669.  
  13670.                     # but otherwise, do not recombine unless this will leave
  13671.                     # just 1 more line
  13672.                     else {
  13673.                         next unless ( $n + 1 >= $nmax );
  13674.                     }
  13675.                 }
  13676.  
  13677.                 # opening paren..
  13678.                 elsif ( $types_to_go[$imid] eq '(' ) {
  13679.  
  13680.                     # No longer doing this
  13681.                 }
  13682.  
  13683.                 elsif ( $types_to_go[$imid] eq ')' ) {
  13684.  
  13685.                     # No longer doing this
  13686.                 }
  13687.  
  13688.                 # keep a terminal colon
  13689.                 elsif ( $types_to_go[$imid] eq ':' ) {
  13690.                     next;
  13691.                 }
  13692.  
  13693.                 # keep a terminal for-semicolon
  13694.                 elsif ( $types_to_go[$imid] eq 'f' ) {
  13695.                     next;
  13696.                 }
  13697.  
  13698.                 # if '=' at end of line ...
  13699.                 elsif ( $types_to_go[$imid] eq '=' ) {
  13700.  
  13701.                     # always ok to join isolated '='
  13702.                     unless ( $if == $imid ) {
  13703.  
  13704.                         my $is_math = (
  13705.                             ( $types_to_go[$il] =~ /^[+-\/\*\)]$/ )
  13706.  
  13707.                    # note no '$' in pattern because -> can start long identifier
  13708.                               && !grep { $_ =~ /^(->|=>|[\,])/ }
  13709.                               @types_to_go[ $imidr .. $il ]
  13710.                         );
  13711.  
  13712.                         # retain the break after the '=' unless ...
  13713.                         next
  13714.                           unless (
  13715.  
  13716.                             # '=' is followed by a number and looks like math
  13717.                             ( $types_to_go[$imidr] eq 'n' && $is_math )
  13718.  
  13719.                             # or followed by a scalar and looks like math
  13720.                             || (   ( $types_to_go[$imidr] eq 'i' )
  13721.                                 && ( $tokens_to_go[$imidr] =~ /^\$/ )
  13722.                                 && $is_math )
  13723.  
  13724.                             # or followed by a single "short" token
  13725.                             # ('12' is arbitrary)
  13726.                             || ( $il == $imidr
  13727.                                 && token_sequence_length( $imidr, $imidr ) <
  13728.                                 12 )
  13729.  
  13730.                           );
  13731.                     }
  13732.                     unless ( $tokens_to_go[$imidr] =~ /^[\{\(\[]$/ ) {
  13733.                         $forced_breakpoint_to_go[$imid] = 0;
  13734.                     }
  13735.                 }
  13736.  
  13737.                 # for keywords..
  13738.                 elsif ( $types_to_go[$imid] eq 'k' ) {
  13739.  
  13740.                     # make major control keywords stand out
  13741.                     # (recombine.t)
  13742.                     next
  13743.                       if (
  13744.  
  13745.                         #/^(last|next|redo|return)$/
  13746.                         $is_last_next_redo_return{ $tokens_to_go[$imid] }
  13747.                       );
  13748.                 }
  13749.  
  13750.                 #----------------------------------------------------------
  13751.                 # examine token at $imidr (left end of second line of pair)
  13752.                 #----------------------------------------------------------
  13753.  
  13754.                 # do not recombine lines with leading &&, ||, or :
  13755.                 if ( $types_to_go[$imidr] =~ /^(|:|\&\&|\|\|)$/ ) {
  13756.                     next;
  13757.                 }
  13758.  
  13759.                 # Identify and recombine a broken ?/: chain
  13760.                 elsif ( $types_to_go[$imidr] eq '?' ) {
  13761.  
  13762.                     # indexes of line first tokens --
  13763.                     #  mm  - line before previous line
  13764.                     #  f   - previous line
  13765.                     #     <-- this line
  13766.                     #  ff  - next line
  13767.                     #  fff - line after next
  13768.                     my $iff  = $n < $nmax      ? $$ri_first[ $n + 1 ] : -1;
  13769.                     my $ifff = $n + 2 <= $nmax ? $$ri_first[ $n + 2 ] : -1;
  13770.                     my $imm  = $n > 1          ? $$ri_first[ $n - 2 ] : -1;
  13771.                     my $seqno = $type_sequence_to_go[$imidr];
  13772.                     my $f_ok  =
  13773.                       (      $tokens_to_go[$if] eq ':'
  13774.                           && $type_sequence_to_go[$if] ==
  13775.                           $seqno - TYPE_SEQUENCE_INCREMENT );
  13776.                     my $mm_ok =
  13777.                       (      $imm >= 0
  13778.                           && $tokens_to_go[$imm] eq ':'
  13779.                           && $type_sequence_to_go[$imm] ==
  13780.                           $seqno - 2 * TYPE_SEQUENCE_INCREMENT );
  13781.  
  13782.                     my $ff_ok =
  13783.                       (      $iff > 0
  13784.                           && $tokens_to_go[$iff] eq ':'
  13785.                           && $type_sequence_to_go[$iff] == $seqno );
  13786.                     my $fff_ok =
  13787.                       (      $ifff > 0
  13788.                           && $tokens_to_go[$ifff] eq ':'
  13789.                           && $type_sequence_to_go[$ifff] ==
  13790.                           $seqno + TYPE_SEQUENCE_INCREMENT );
  13791.  
  13792.                     # we require that this '?' be part of a correct sequence
  13793.                     # of 3 in a row or else no recombination is done.
  13794.                     next
  13795.                       unless ( ( $ff_ok || $mm_ok ) && ( $f_ok || $fff_ok ) );
  13796.                     $forced_breakpoint_to_go[$imid] = 0;
  13797.                 }
  13798.  
  13799.                 # do not recombine lines with leading '.'
  13800.                 elsif ( $types_to_go[$imidr] =~ /^(\.)$/ ) {
  13801.                     my $i_next_nonblank = $imidr + 1;
  13802.                     if ( $types_to_go[$i_next_nonblank] eq 'b' ) {
  13803.                         $i_next_nonblank++;
  13804.                     }
  13805.  
  13806.                     next
  13807.                       unless (
  13808.  
  13809.      #      ... unless there is just one and we can reduce this to
  13810.      #      two lines if we do.  For example, this :
  13811.      #
  13812.      #                $bodyA .=
  13813.      #                  '($dummy, $pat) = &get_next_tex_cmd;' . '$args .= $pat;'
  13814.      #
  13815.      #      looks better than this:
  13816.      #                $bodyA .= '($dummy, $pat) = &get_next_tex_cmd;'
  13817.      #                   . '$args .= $pat;'
  13818.  
  13819.                         (
  13820.                                $n == 2
  13821.                             && $n == $nmax
  13822.                             && $types_to_go[$if] ne $types_to_go[$imidr]
  13823.                         )
  13824.  
  13825.                        #
  13826.                        #      ... or this would strand a short quote , like this
  13827.                        #                . "some long qoute"
  13828.                        #                . "\n";
  13829.                        #
  13830.  
  13831.                         || (   $types_to_go[$i_next_nonblank] eq 'Q'
  13832.                             && $i_next_nonblank >= $il - 1
  13833.                             && length( $tokens_to_go[$i_next_nonblank] ) <
  13834.                             $rOpts_short_concatenation_item_length )
  13835.                       );
  13836.                 }
  13837.  
  13838.                 # handle leading keyword..
  13839.                 elsif ( $types_to_go[$imidr] eq 'k' ) {
  13840.  
  13841.                     # handle leading "and" and "or"
  13842.                     if ( $is_and_or{ $tokens_to_go[$imidr] } ) {
  13843.  
  13844.                        # Decide if we will combine a single terminal 'and' and
  13845.                        # 'or' after an 'if' or 'unless'.  We should consider the
  13846.                        # possible vertical alignment, and visual clutter.
  13847.  
  13848.   #     This looks best with the 'and' on the same line as the 'if':
  13849.   #
  13850.   #         $a = 1
  13851.   #           if $seconds and $nu < 2;
  13852.   #
  13853.   #     But this looks better as shown:
  13854.   #
  13855.   #         $a = 1
  13856.   #           if !$this->{Parents}{$_}
  13857.   #           or $this->{Parents}{$_} eq $_;
  13858.   #
  13859.   #     Eventually, it would be nice to look for similarities (such as 'this' or
  13860.   #     'Parents'), but for now I'm using a simple rule that says that the
  13861.   #     resulting line length must not be more than half the maximum line length
  13862.   #     (making it 80/2 = 40 characters by default).
  13863.  
  13864.                         next
  13865.                           unless (
  13866.                             $n == $nmax    # if this is the last line
  13867.                             && $types_to_go[$il] eq ';' # ending in ';'
  13868.                             && $types_to_go[$if] eq 'k' # after 'if' or 'unless'
  13869.                                                         #   /^(if|unless)$/
  13870.                             && $is_if_unless{ $tokens_to_go[$if] }
  13871.  
  13872.                             # and if this doesn't make a long last line
  13873.                             && total_line_length( $if, $il ) <=
  13874.                             $half_maximum_line_length
  13875.                           );
  13876.  
  13877.                         # override breakpoint
  13878.                         $forced_breakpoint_to_go[$imid] = 0;
  13879.                     }
  13880.  
  13881.                     # handle leading "if" and "unless"
  13882.                     elsif ( $is_if_unless{ $tokens_to_go[$imidr] } ) {
  13883.  
  13884.                       # FIXME: This is still experimental..may not be too useful
  13885.                         next
  13886.                           unless (
  13887.                             $n == $nmax    # if this is the last line
  13888.                             && $types_to_go[$il] eq ';'    # ending in ';'
  13889.                             && $types_to_go[$if] eq 'k'
  13890.  
  13891.                             #   /^(and|or)$/
  13892.                             && $is_and_or{ $tokens_to_go[$if] }
  13893.  
  13894.                             # and if this doesn't make a long last line
  13895.                             && total_line_length( $if, $il ) <=
  13896.                             $half_maximum_line_length
  13897.                           );
  13898.  
  13899.                         # override breakpoint
  13900.                         $forced_breakpoint_to_go[$imid] = 0;
  13901.                     }
  13902.  
  13903.                     # handle all other leading keywords
  13904.                     else {
  13905.  
  13906.                         # keywords look best at start of lines,
  13907.                         # but combine things like "1 while"
  13908.  
  13909.                         unless ( $types_to_go[$imid] eq '=' ) {
  13910.                             next
  13911.                               if ( ( $types_to_go[$imid] ne 'k' )
  13912.                                 && ( $tokens_to_go[$imidr] !~ /^(while)$/ ) );
  13913.                         }
  13914.                     }
  13915.                 }
  13916.  
  13917.                 # similar treatment of && and || as above for 'and' and 'or':
  13918.                 elsif ( $types_to_go[$imidr] =~ /^(&&|\|\|)$/ ) {
  13919.  
  13920.                     # maybe looking at something like:
  13921.                     #   unless $TEXTONLY || $item =~ m%</?(hr>|p>|a|img)%i;
  13922.  
  13923.                     next
  13924.                       unless (
  13925.                         $n == $nmax    # if this is the last line
  13926.                         && $types_to_go[$il] eq ';'  # ending in ';'
  13927.                         && $types_to_go[$if] eq 'k'  # after an 'if' or 'unless'
  13928.                                                      #   /^(if|unless)$/
  13929.                         && $is_if_unless{ $tokens_to_go[$if] }
  13930.  
  13931.                         # and if this doesn't make a long last line
  13932.                         && total_line_length( $if, $il ) <=
  13933.                         $half_maximum_line_length
  13934.                       );
  13935.  
  13936.                     # override breakpoint
  13937.                     $forced_breakpoint_to_go[$imid] = 0;
  13938.                 }
  13939.  
  13940.                 # honor hard breakpoints
  13941.                 next if ( $forced_breakpoint_to_go[$imid] > 0 );
  13942.  
  13943.                 #----------------------------------------------------------
  13944.                 # end of special recombination rules
  13945.                 #----------------------------------------------------------
  13946.  
  13947.                 my $bs = $bond_strength_to_go[$imid];
  13948.  
  13949.                 # combined line cannot be too long
  13950.                 next
  13951.                   if excess_line_length( $if, $il ) > 0;
  13952.  
  13953.                 # do not recombine if we would skip in indentation levels
  13954.                 if ( $n < $nmax ) {
  13955.                     my $if_next = $$ri_first[ $n + 1 ];
  13956.                     next
  13957.                       if (
  13958.                            $levels_to_go[$if] < $levels_to_go[$imidr]
  13959.                         && $levels_to_go[$imidr] < $levels_to_go[$if_next]
  13960.  
  13961.                         # but an isolated 'if (' is undesirable
  13962.                         && !(
  13963.                                $n == 1
  13964.                             && $imid - $if <= 2
  13965.                             && $types_to_go[$if]  eq 'k'
  13966.                             && $tokens_to_go[$if] eq 'if'
  13967.                             && $tokens_to_go[$imid] ne '('
  13968.                         )
  13969.  
  13970.                         #
  13971.                       );
  13972.                 }
  13973.  
  13974.                 # honor no-break's
  13975.                 next if ( $bs == NO_BREAK );
  13976.  
  13977.                 # remember the pair with the greatest bond strength
  13978.                 if ( !$n_best ) {
  13979.                     $n_best  = $n;
  13980.                     $bs_best = $bs;
  13981.                 }
  13982.                 else {
  13983.  
  13984.                     if ( $bs > $bs_best ) {
  13985.                         $n_best  = $n;
  13986.                         $bs_best = $bs;
  13987.                     }
  13988.  
  13989.                     # we have 2 or more candidates, so need another pass
  13990.                     $more_to_do++;
  13991.                 }
  13992.             }
  13993.  
  13994.             # recombine the pair with the greatest bond strength
  13995.             if ($n_best) {
  13996.                 splice @$ri_first, $n_best, 1;
  13997.                 splice @$ri_last, $n_best - 1, 1;
  13998.             }
  13999.         }
  14000.         return ( $ri_first, $ri_last );
  14001.     }
  14002. }
  14003.  
  14004. sub set_continuation_breaks {
  14005.  
  14006.     # Define an array of indexes for inserting newline characters to
  14007.     # keep the line lengths below the maximum desired length.  There is
  14008.     # an implied break after the last token, so it need not be included.
  14009.     # We'll break at points where the bond strength is lowest.
  14010.  
  14011.     my $saw_good_break = shift;
  14012.     my @i_first        = ();      # the first index to output
  14013.     my @i_last         = ();      # the last index to output
  14014.     my @i_colon_breaks = ();      # needed to decide if we have to break at ?'s
  14015.     if ( $tokens_to_go[0] eq ':' ) { push @i_colon_breaks, 0 }
  14016.  
  14017.     set_bond_strengths();
  14018.  
  14019.     my $imin = 0;
  14020.     my $imax = $max_index_to_go;
  14021.     if ( $types_to_go[$imin] eq 'b' ) { $imin++ }
  14022.     if ( $types_to_go[$imax] eq 'b' ) { $imax-- }
  14023.     my $i_begin = $imin;
  14024.  
  14025.     my $leading_spaces          = leading_spaces_to_go($imin);
  14026.     my $line_count              = 0;
  14027.     my $last_break_strength     = NO_BREAK;
  14028.     my $i_last_break            = -1;
  14029.     my $max_bias                = 0.001;
  14030.     my $tiny_bias               = 0.0001;
  14031.     my $leading_alignment_token = "";
  14032.     my $leading_alignment_type  = "";
  14033.  
  14034.     # see if any ?/:'s are in order
  14035.     my $colons_in_order = 1;
  14036.     my $last_tok        = "";
  14037.     my @colon_list = grep /^[\?\:]$/, @tokens_to_go[ 0 .. $max_index_to_go ];
  14038.     foreach (@colon_list) {
  14039.         if ( $_ eq $last_tok ) { $colons_in_order = 0; last }
  14040.         $last_tok = $_;
  14041.     }
  14042.  
  14043.     # This is a sufficient but not necessary condition for colon chain
  14044.     my $is_colon_chain = ( $colons_in_order && @colon_list > 2 );
  14045.  
  14046.     while ( $i_begin <= $imax ) {
  14047.         my $lowest_strength        = NO_BREAK;
  14048.         my $starting_sum           = $lengths_to_go[$i_begin];
  14049.         my $i_lowest               = -1;
  14050.         my $i_test                 = -1;
  14051.         my $lowest_next_token      = '';
  14052.         my $lowest_next_type       = 'b';
  14053.         my $i_lowest_next_nonblank = -1;
  14054.  
  14055.         # loop to find next break point
  14056.         for ( $i_test = $i_begin ; $i_test <= $imax ; $i_test++ ) {
  14057.             my $type            = $types_to_go[$i_test];
  14058.             my $token           = $tokens_to_go[$i_test];
  14059.             my $next_type       = $types_to_go[ $i_test + 1 ];
  14060.             my $next_token      = $tokens_to_go[ $i_test + 1 ];
  14061.             my $i_next_nonblank =
  14062.               ( ( $next_type eq 'b' ) ? $i_test + 2 : $i_test + 1 );
  14063.             my $next_nonblank_type       = $types_to_go[$i_next_nonblank];
  14064.             my $next_nonblank_token      = $tokens_to_go[$i_next_nonblank];
  14065.             my $next_nonblank_block_type = $block_type_to_go[$i_next_nonblank];
  14066.             my $strength                 = $bond_strength_to_go[$i_test];
  14067.             my $must_break               = 0;
  14068.  
  14069.             # FIXME: TESTING: Might want to be able to break after these
  14070.             # force an immediate break at certain operators
  14071.             # with lower level than the start of the line
  14072.             if (
  14073.                 (
  14074.                     $next_nonblank_type =~ /^(\.|\&\&|\|\|)$/
  14075.                     || (   $next_nonblank_type eq 'k'
  14076.                         && $next_nonblank_token =~ /^(and|or)$/ )
  14077.                 )
  14078.                 && ( $nesting_depth_to_go[$i_begin] >
  14079.                     $nesting_depth_to_go[$i_next_nonblank] )
  14080.               )
  14081.             {
  14082.                 set_forced_breakpoint($i_next_nonblank);
  14083.             }
  14084.  
  14085.             if (
  14086.  
  14087.                 # Try to put a break where requested by scan_list
  14088.                 $forced_breakpoint_to_go[$i_test]
  14089.  
  14090.                 # break between ) { in a continued line so that the '{' can
  14091.                 # be outdented
  14092.                 # See similar logic in scan_list which catches instances
  14093.                 # where a line is just something like ') {'
  14094.                 || (   $line_count
  14095.                     && ( $token eq ')' )
  14096.                     && ( $next_nonblank_type eq '{' )
  14097.                     && ($next_nonblank_block_type)
  14098.                     && !$rOpts->{'opening-brace-always-on-right'} )
  14099.  
  14100.                 # There is an implied forced break at a terminal opening brace
  14101.                 || ( ( $type eq '{' ) && ( $i_test == $imax ) )
  14102.  
  14103.               )
  14104.             {
  14105.  
  14106.                 # Forced breakpoints must sometimes be overridden, for example
  14107.                 # because of a side comment causing a NO_BREAK.  It is easier
  14108.                 # to catch this here than when they are set.
  14109.                 if ( $strength < NO_BREAK ) {
  14110.                     $strength   = $lowest_strength - $tiny_bias;
  14111.                     $must_break = 1;
  14112.                 }
  14113.             }
  14114.  
  14115.             # quit if a break here would put a good terminal token on
  14116.             # the next line and we already have a possible break
  14117.             if (
  14118.                    !$must_break
  14119.                 && ( $next_nonblank_type =~ /^[\;\,]$/ )
  14120.                 && (
  14121.                     (
  14122.                         $leading_spaces + $lengths_to_go[ $i_next_nonblank + 1 ]
  14123.                         - $starting_sum
  14124.                     ) > $rOpts_maximum_line_length
  14125.                 )
  14126.               )
  14127.             {
  14128.                 last if ( $i_lowest >= 0 );
  14129.             }
  14130.  
  14131.             # Avoid a break which would strand a single punctuation
  14132.             # token.  For example, we do not want to strand a leading
  14133.             # '.' which is followed by a long quoted string.
  14134.             if (
  14135.                    !$must_break
  14136.                 && ( $i_test == $i_begin )
  14137.                 && ( $i_test < $imax )
  14138.                 && ( $token eq $type )
  14139.                 && (
  14140.                     (
  14141.                         $leading_spaces + $lengths_to_go[ $i_test + 1 ] -
  14142.                         $starting_sum
  14143.                     ) <= $rOpts_maximum_line_length
  14144.                 )
  14145.               )
  14146.             {
  14147.                 $i_test++;
  14148.  
  14149.                 if ( ( $i_test < $imax ) && ( $next_type eq 'b' ) ) {
  14150.                     $i_test++;
  14151.                 }
  14152.                 redo;
  14153.             }
  14154.  
  14155.             if ( ( $strength <= $lowest_strength ) && ( $strength < NO_BREAK ) )
  14156.             {
  14157.  
  14158.                 # break at previous best break if it would have produced
  14159.                 # a leading alignment of certain common tokens, and it
  14160.                 # is different from the latest candidate break
  14161.                 last
  14162.                   if ($leading_alignment_type);
  14163.  
  14164.                 # Force at least one breakpoint if old code had good
  14165.                 # break It is only called if a breakpoint is required or
  14166.                 # desired.  This will probably need some adjustments
  14167.                 # over time.  A goal is to try to be sure that, if a new
  14168.                 # side comment is introduced into formated text, then
  14169.                 # the same breakpoints will occur.  scbreak.t
  14170.                 last
  14171.                   if (
  14172.                     $i_test == $imax                # we are at the end
  14173.                     && !$forced_breakpoint_count    #
  14174.                     && $saw_good_break              # old line had good break
  14175.                     && $type =~ /^[#;\{]$/          # and this line ends in
  14176.                                                     # ';' or side comment
  14177.                     && $i_last_break < 0        # and we haven't made a break
  14178.                     && $i_lowest > 0            # and we saw a possible break
  14179.                     && $i_lowest < $imax - 1    # (but not just before this ;)
  14180.                     && $strength - $lowest_strength < 0.5 * WEAK # and it's good
  14181.                   );
  14182.  
  14183.                 $lowest_strength        = $strength;
  14184.                 $i_lowest               = $i_test;
  14185.                 $lowest_next_token      = $next_nonblank_token;
  14186.                 $lowest_next_type       = $next_nonblank_type;
  14187.                 $i_lowest_next_nonblank = $i_next_nonblank;
  14188.                 last if $must_break;
  14189.  
  14190.                 # set flags to remember if a break here will produce a
  14191.                 # leading alignment of certain common tokens
  14192.                 if (
  14193.                        $line_count > 0
  14194.                     && $i_test < $imax
  14195.                     && ( $lowest_strength - $last_break_strength <= $max_bias )
  14196.                     && ( $nesting_depth_to_go[$i_begin] >=
  14197.                         $nesting_depth_to_go[$i_next_nonblank] )
  14198.                     && (
  14199.                         (
  14200.                                $types_to_go[$i_begin] =~ /^(\.|\&\&|\|\||:)$/
  14201.                             && $types_to_go[$i_begin] eq $next_nonblank_type
  14202.                         )
  14203.                         || (   $tokens_to_go[$i_begin] =~ /^(and|or)$/
  14204.                             && $tokens_to_go[$i_begin] eq $next_nonblank_token )
  14205.                     )
  14206.                   )
  14207.                 {
  14208.                     $leading_alignment_token = $next_nonblank_token;
  14209.                     $leading_alignment_type  = $next_nonblank_type;
  14210.                 }
  14211.             }
  14212.  
  14213.             my $too_long =
  14214.               ( $i_test >= $imax )
  14215.               ? 1
  14216.               : (
  14217.                 (
  14218.                     $leading_spaces + $lengths_to_go[ $i_test + 2 ] -
  14219.                       $starting_sum
  14220.                 ) > $rOpts_maximum_line_length
  14221.               );
  14222.  
  14223.             FORMATTER_DEBUG_FLAG_BREAK
  14224.               && print
  14225. "BREAK: testing i = $i_test imax=$imax $types_to_go[$i_test] $next_nonblank_type leading sp=($leading_spaces) next length = $lengths_to_go[$i_test+2] too_long=$too_long str=$strength\n";
  14226.  
  14227.             # allow one extra terminal token after exceeding line length
  14228.             # if it would strand this token.
  14229.             if (   $rOpts_fuzzy_line_length
  14230.                 && $too_long
  14231.                 && ( $i_lowest == $i_test )
  14232.                 && ( length($token) > 1 )
  14233.                 && ( $next_nonblank_type =~ /^[\;\,]$/ ) )
  14234.             {
  14235.                 $too_long = 0;
  14236.             }
  14237.  
  14238.             last
  14239.               if (
  14240.                 ( $i_test == $imax )    # we're done if no more tokens,
  14241.                 || (
  14242.                     ( $i_lowest >= 0 )    # or no more space and we have a break
  14243.                     && $too_long
  14244.                 )
  14245.               );
  14246.         }
  14247.  
  14248.         # it's always ok to break at imax if no other break was found
  14249.         if ( $i_lowest < 0 ) { $i_lowest = $imax }
  14250.  
  14251.         # semi-final index calculation
  14252.         my $i_next_nonblank = (
  14253.             ( $types_to_go[ $i_lowest + 1 ] eq 'b' )
  14254.             ? $i_lowest + 2
  14255.             : $i_lowest + 1
  14256.         );
  14257.         my $next_nonblank_type  = $types_to_go[$i_next_nonblank];
  14258.         my $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
  14259.  
  14260.         #-------------------------------------------------------
  14261.         # ?/: rule 1 : if a break here will separate a '?' on this
  14262.         # line from its closing ':', then break at the '?' instead.
  14263.         #-------------------------------------------------------
  14264.         my $i;
  14265.         foreach $i ( $i_begin + 1 .. $i_lowest - 1 ) {
  14266.             next unless ( $tokens_to_go[$i] eq '?' );
  14267.  
  14268.             # do not break if probable sequence of ?/: statements
  14269.             next if ($is_colon_chain);
  14270.  
  14271.             # do not break if statement is broken by side comment
  14272.             next
  14273.               if (
  14274.                 $tokens_to_go[$max_index_to_go] eq '#'
  14275.                 && terminal_type( \@types_to_go, \@block_type_to_go, 0,
  14276.                     $max_index_to_go ) !~ /^[\;\}]$/
  14277.               );
  14278.  
  14279.             # no break needed if matching : is also on the line
  14280.             next
  14281.               if ( $mate_index_to_go[$i] >= 0
  14282.                 && $mate_index_to_go[$i] <= $i_next_nonblank );
  14283.  
  14284.             $i_lowest = $i;
  14285.             if ( $want_break_before{'?'} ) { $i_lowest-- }
  14286.             last;
  14287.         }
  14288.  
  14289.         # final index calculation
  14290.         $i_next_nonblank = (
  14291.             ( $types_to_go[ $i_lowest + 1 ] eq 'b' )
  14292.             ? $i_lowest + 2
  14293.             : $i_lowest + 1
  14294.         );
  14295.         $next_nonblank_type  = $types_to_go[$i_next_nonblank];
  14296.         $next_nonblank_token = $tokens_to_go[$i_next_nonblank];
  14297.  
  14298.         FORMATTER_DEBUG_FLAG_BREAK
  14299.           && print "BREAK: best is i = $i_lowest strength = $lowest_strength\n";
  14300.  
  14301.         #-------------------------------------------------------
  14302.         # ?/: rule 2 : if we break at a '?', then break at its ':'
  14303.         #
  14304.         # Note: this rule is also in sub scan_list to handle a break
  14305.         # at the start and end of a line (in case breaks are dictated
  14306.         # by side comments).
  14307.         #-------------------------------------------------------
  14308.         if ( $next_nonblank_type eq '?' ) {
  14309.             set_closing_breakpoint($i_next_nonblank);
  14310.         }
  14311.         elsif ( $types_to_go[$i_lowest] eq '?' ) {
  14312.             set_closing_breakpoint($i_lowest);
  14313.         }
  14314.  
  14315.         #-------------------------------------------------------
  14316.         # ?/: rule 3 : if we break at a ':' then we save
  14317.         # its location for further work below.  We may need to go
  14318.         # back and break at its '?'.
  14319.         #-------------------------------------------------------
  14320.         if ( $next_nonblank_type eq ':' ) {
  14321.             push @i_colon_breaks, $i_next_nonblank;
  14322.         }
  14323.         elsif ( $types_to_go[$i_lowest] eq ':' ) {
  14324.             push @i_colon_breaks, $i_lowest;
  14325.         }
  14326.  
  14327.         # here we should set breaks for all '?'/':' pairs which are
  14328.         # separated by this line
  14329.  
  14330.         $line_count++;
  14331.  
  14332.         # save this line segment, after trimming blanks at the ends
  14333.         push ( @i_first,
  14334.             ( $types_to_go[$i_begin] eq 'b' ) ? $i_begin + 1 : $i_begin );
  14335.         push ( @i_last,
  14336.             ( $types_to_go[$i_lowest] eq 'b' ) ? $i_lowest - 1 : $i_lowest );
  14337.  
  14338.         # set a forced breakpoint at a container opening, if necessary, to
  14339.         # signal a break at a closing container.  Excepting '(' for now.
  14340.         if ( $tokens_to_go[$i_lowest] =~ /^[\{\[]$/
  14341.             && !$forced_breakpoint_to_go[$i_lowest] )
  14342.         {
  14343.             set_closing_breakpoint($i_lowest);
  14344.         }
  14345.  
  14346.         # get ready to go again
  14347.         $i_begin                 = $i_lowest + 1;
  14348.         $last_break_strength     = $lowest_strength;
  14349.         $i_last_break            = $i_lowest;
  14350.         $leading_alignment_token = "";
  14351.         $leading_alignment_type  = "";
  14352.         $lowest_next_token       = '';
  14353.         $lowest_next_type        = 'b';
  14354.  
  14355.         if ( ( $i_begin <= $imax ) && ( $types_to_go[$i_begin] eq 'b' ) ) {
  14356.             $i_begin++;
  14357.         }
  14358.  
  14359.         # update indentation size
  14360.         if ( $i_begin <= $imax ) {
  14361.             $leading_spaces = leading_spaces_to_go($i_begin);
  14362.         }
  14363.     }
  14364.  
  14365.     #-------------------------------------------------------
  14366.     # ?/: rule 4 -- if we broke at a ':', then break at
  14367.     # corresponding '?' unless this is a chain of ?: expressions
  14368.     #-------------------------------------------------------
  14369.     if (@i_colon_breaks) {
  14370.  
  14371.         # using a simple method for deciding if we are in a ?/: chain --
  14372.         # this is a chain if it has multiple ?/: pairs all in order;
  14373.         # otherwise not.
  14374.         # Note that if line starts in a ':' we count that above as a break
  14375.         my $is_chain = ( $colons_in_order && @i_colon_breaks > 1 );
  14376.  
  14377.         unless ($is_chain) {
  14378.             my @insert_list = ();
  14379.             foreach (@i_colon_breaks) {
  14380.                 my $i_question = $mate_index_to_go[$_];
  14381.                 if ( $i_question >= 0 ) {
  14382.                     if ( $want_break_before{'?'} ) {
  14383.                         $i_question--;
  14384.                         if (   $i_question > 0
  14385.                             && $types_to_go[$i_question] eq 'b' )
  14386.                         {
  14387.                             $i_question--;
  14388.                         }
  14389.                     }
  14390.  
  14391.                     if ( $i_question >= 0 ) {
  14392.                         push @insert_list, $i_question;
  14393.                     }
  14394.                 }
  14395.                 insert_additional_breaks( \@insert_list, \@i_first, \@i_last );
  14396.             }
  14397.         }
  14398.     }
  14399.     return \@i_first, \@i_last;
  14400. }
  14401.  
  14402. sub insert_additional_breaks {
  14403.  
  14404.     # this routine will add line breaks at requested locations after
  14405.     # sub set_continuation_breaks has made preliminary breaks.
  14406.  
  14407.     my ( $ri_break_list, $ri_first, $ri_last ) = @_;
  14408.     my $i_f;
  14409.     my $i_l;
  14410.     my $line_number = 0;
  14411.     my $i_break_left;
  14412.     foreach $i_break_left ( sort @$ri_break_list ) {
  14413.  
  14414.         $i_f = $$ri_first[$line_number];
  14415.         $i_l = $$ri_last[$line_number];
  14416.         while ( $i_break_left >= $i_l ) {
  14417.             $line_number++;
  14418.  
  14419.             # shouldn't happen unless caller passes bad indexes
  14420.             if ( $line_number >= @$ri_last ) {
  14421.                 warning(
  14422. "Non-fatal program bug: couldn't set break at $i_break_left\n"
  14423.                 );
  14424.                 report_definite_bug();
  14425.                 return;
  14426.             }
  14427.             $i_f = $$ri_first[$line_number];
  14428.             $i_l = $$ri_last[$line_number];
  14429.         }
  14430.  
  14431.         my $i_break_right = $i_break_left + 1;
  14432.         if ( $types_to_go[$i_break_right] eq 'b' ) { $i_break_right++ }
  14433.  
  14434.         if (   $i_break_left >= $i_f
  14435.             && $i_break_left < $i_l
  14436.             && $i_break_right > $i_f
  14437.             && $i_break_right <= $i_l )
  14438.         {
  14439.             splice( @$ri_first, $line_number, 1, ( $i_f, $i_break_right ) );
  14440.             splice( @$ri_last, $line_number, 1, ( $i_break_left, $i_l ) );
  14441.         }
  14442.     }
  14443. }
  14444.  
  14445. sub set_closing_breakpoint {
  14446.  
  14447.     # set a breakpoint at a matching closing token
  14448.     # at present, this is only used to break at a ':' which matches a '?'
  14449.     my $i_break = shift;
  14450.  
  14451.     if ( $mate_index_to_go[$i_break] >= 0 ) {
  14452.  
  14453.         # CAUTION: infinite recursion possible here:
  14454.         #   set_closing_breakpoint calls set_forced_breakpoint, and
  14455.         #   set_forced_breakpoint call set_closing_breakpoint
  14456.         #   ( test files attrib.t, BasicLyx.pm.html).
  14457.         # Don't reduce the '2' in the statement below
  14458.         if ( $mate_index_to_go[$i_break] > $i_break + 2 ) {
  14459.  
  14460.             # break before } ] and ), but sub set_forced_breakpoint will decide
  14461.             # to break before or after a ? and :
  14462.             my $inc = ( $tokens_to_go[$i_break] eq '?' ) ? 0 : 1;
  14463.             set_forced_breakpoint( $mate_index_to_go[$i_break] - $inc );
  14464.         }
  14465.     }
  14466.     else {
  14467.         my $type_sequence = $type_sequence_to_go[$i_break];
  14468.         if ($type_sequence) {
  14469.             my $closing_token = $matching_token{ $tokens_to_go[$i_break] };
  14470.             $postponed_breakpoint{$type_sequence} = 1;
  14471.         }
  14472.     }
  14473. }
  14474.  
  14475. # check to see if output line tabbing agrees with input line
  14476. # this can be very useful for debugging a script which has an extra
  14477. # or missing brace
  14478. sub compare_indentation_levels {
  14479.  
  14480.     my ( $python_indentation_level, $structural_indentation_level ) = @_;
  14481.     if ( ( $python_indentation_level ne $structural_indentation_level ) ) {
  14482.         $last_tabbing_disagreement = $input_line_number;
  14483.  
  14484.         if ($in_tabbing_disagreement) {
  14485.         }
  14486.         else {
  14487.             $tabbing_disagreement_count++;
  14488.  
  14489.             if ( $tabbing_disagreement_count <= MAX_NAG_MESSAGES ) {
  14490.                 write_logfile_entry(
  14491. "Start indentation disagreement: input=$python_indentation_level; output=$structural_indentation_level\n"
  14492.                 );
  14493.             }
  14494.             $in_tabbing_disagreement    = $input_line_number;
  14495.             $first_tabbing_disagreement = $in_tabbing_disagreement
  14496.               unless ($first_tabbing_disagreement);
  14497.         }
  14498.     }
  14499.     else {
  14500.  
  14501.         if ($in_tabbing_disagreement) {
  14502.  
  14503.             if ( $tabbing_disagreement_count <= MAX_NAG_MESSAGES ) {
  14504.                 write_logfile_entry(
  14505. "End indentation disagreement from input line $in_tabbing_disagreement\n"
  14506.                 );
  14507.  
  14508.                 if ( $tabbing_disagreement_count == MAX_NAG_MESSAGES ) {
  14509.                     write_logfile_entry(
  14510.                         "No further tabbing disagreements will be noted\n");
  14511.                 }
  14512.             }
  14513.             $in_tabbing_disagreement = 0;
  14514.         }
  14515.     }
  14516. }
  14517.  
  14518. #####################################################################
  14519. #
  14520. # the Perl::Tidy::IndentationItem class supplies items which contain
  14521. # how much whitespace should be used at the start of a line
  14522. #
  14523. #####################################################################
  14524.  
  14525. package Perl::Tidy::IndentationItem;
  14526.  
  14527. # Indexes for indentation items
  14528. use constant SPACES             => 0;     # total leading white spaces
  14529. use constant LEVEL              => 1;     # the indentation 'level'
  14530. use constant CI_LEVEL           => 2;     # the 'continuation level'
  14531. use constant AVAILABLE_SPACES   => 3;     # how many left spaces available
  14532.                                           # for this level
  14533. use constant CLOSED             => 4;     # index where we saw closing '}'
  14534. use constant COMMA_COUNT        => 5;     # how many commas at this level?
  14535. use constant SEQUENCE_NUMBER    => 6;     # output batch number
  14536. use constant INDEX              => 7;     # index in output batch list
  14537. use constant HAVE_CHILD         => 8;     # any dependents?
  14538. use constant RECOVERABLE_SPACES => 9;     # how many spaces to the right
  14539.                                           # we would like to move to get
  14540.                                           # alignment (negative if left)
  14541. use constant ALIGN_PAREN        => 10;    # do we want to try to align
  14542.                                           # with an opening structure?
  14543. use constant MARKED             => 11;    # if visited by corrector logic
  14544. use constant STACK_DEPTH        => 12;    # indentation nesting depth
  14545. use constant STARTING_INDEX     => 13;    # first token index of this level
  14546. use constant ARROW_COUNT        => 14;    # how many =>'s
  14547.  
  14548. sub new {
  14549.  
  14550.     # Create an 'indentation_item' which describes one level of leading
  14551.     # whitespace when the '-lp' indentation is used.  We return
  14552.     # a reference to an anonymous array of associated variables.
  14553.     # See above constants for storage scheme.
  14554.     my (
  14555.         $class,               $spaces,           $level,
  14556.         $ci_level,            $available_spaces, $index,
  14557.         $gnu_sequence_number, $align_paren,      $stack_depth,
  14558.         $starting_index,
  14559.       )
  14560.       = @_;
  14561.     my $closed            = -1;
  14562.     my $arrow_count       = 0;
  14563.     my $comma_count       = 0;
  14564.     my $have_child        = 0;
  14565.     my $want_right_spaces = 0;
  14566.     my $marked            = 0;
  14567.     bless [
  14568.         $spaces,              $level,          $ci_level,
  14569.         $available_spaces,    $closed,         $comma_count,
  14570.         $gnu_sequence_number, $index,          $have_child,
  14571.         $want_right_spaces,   $align_paren,    $marked,
  14572.         $stack_depth,         $starting_index, $arrow_count,
  14573.     ], $class;
  14574. }
  14575.  
  14576. sub permanently_decrease_AVAILABLE_SPACES {
  14577.  
  14578.     # make a permanent reduction in the available indentation spaces
  14579.     # at one indentation item.  NOTE: if there are child nodes, their
  14580.     # total SPACES must be reduced by the caller.
  14581.  
  14582.     my ( $item, $spaces_needed ) = @_;
  14583.     my $available_spaces = $item->get_AVAILABLE_SPACES();
  14584.     my $deleted_spaces   =
  14585.       ( $available_spaces > $spaces_needed )
  14586.       ? $spaces_needed
  14587.       : $available_spaces;
  14588.     $item->decrease_AVAILABLE_SPACES($deleted_spaces);
  14589.     $item->decrease_SPACES($deleted_spaces);
  14590.     $item->set_RECOVERABLE_SPACES(0);
  14591.  
  14592.     return $deleted_spaces;
  14593. }
  14594.  
  14595. sub tentatively_decrease_AVAILABLE_SPACES {
  14596.  
  14597.     # We are asked to tentatively delete $spaces_needed of indentation
  14598.     # for a indentation item.  We may want to undo this later.  NOTE: if
  14599.     # there are child nodes, their total SPACES must be reduced by the
  14600.     # caller.
  14601.     my ( $item, $spaces_needed ) = @_;
  14602.     my $available_spaces = $item->get_AVAILABLE_SPACES();
  14603.     my $deleted_spaces   =
  14604.       ( $available_spaces > $spaces_needed )
  14605.       ? $spaces_needed
  14606.       : $available_spaces;
  14607.     $item->decrease_AVAILABLE_SPACES($deleted_spaces);
  14608.     $item->decrease_SPACES($deleted_spaces);
  14609.     $item->increase_RECOVERABLE_SPACES($deleted_spaces);
  14610.     return $deleted_spaces;
  14611. }
  14612.  
  14613. sub get_STACK_DEPTH {
  14614.     my $self = shift;
  14615.     return $self->[STACK_DEPTH];
  14616. }
  14617.  
  14618. sub get_SPACES {
  14619.     my $self = shift;
  14620.     return $self->[SPACES];
  14621. }
  14622.  
  14623. sub get_MARKED {
  14624.     my $self = shift;
  14625.     return $self->[MARKED];
  14626. }
  14627.  
  14628. sub set_MARKED {
  14629.     my ( $self, $value ) = @_;
  14630.     if ( defined($value) ) {
  14631.         $self->[MARKED] = $value;
  14632.     }
  14633.     return $self->[MARKED];
  14634. }
  14635.  
  14636. sub get_AVAILABLE_SPACES {
  14637.     my $self = shift;
  14638.     return $self->[AVAILABLE_SPACES];
  14639. }
  14640.  
  14641. sub decrease_SPACES {
  14642.     my ( $self, $value ) = @_;
  14643.     if ( defined($value) ) {
  14644.         $self->[SPACES] -= $value;
  14645.     }
  14646.     return $self->[SPACES];
  14647. }
  14648.  
  14649. sub decrease_AVAILABLE_SPACES {
  14650.     my ( $self, $value ) = @_;
  14651.     if ( defined($value) ) {
  14652.         $self->[AVAILABLE_SPACES] -= $value;
  14653.     }
  14654.     return $self->[AVAILABLE_SPACES];
  14655. }
  14656.  
  14657. sub get_ALIGN_PAREN {
  14658.     my $self = shift;
  14659.     return $self->[ALIGN_PAREN];
  14660. }
  14661.  
  14662. sub get_RECOVERABLE_SPACES {
  14663.     my $self = shift;
  14664.     return $self->[RECOVERABLE_SPACES];
  14665. }
  14666.  
  14667. sub set_RECOVERABLE_SPACES {
  14668.     my ( $self, $value ) = @_;
  14669.     if ( defined($value) ) {
  14670.         $self->[RECOVERABLE_SPACES] = $value;
  14671.     }
  14672.     return $self->[RECOVERABLE_SPACES];
  14673. }
  14674.  
  14675. sub increase_RECOVERABLE_SPACES {
  14676.     my ( $self, $value ) = @_;
  14677.     if ( defined($value) ) {
  14678.         $self->[RECOVERABLE_SPACES] += $value;
  14679.     }
  14680.     return $self->[RECOVERABLE_SPACES];
  14681. }
  14682.  
  14683. sub get_CI_LEVEL {
  14684.     my $self = shift;
  14685.     return $self->[CI_LEVEL];
  14686. }
  14687.  
  14688. sub get_LEVEL {
  14689.     my $self = shift;
  14690.     return $self->[LEVEL];
  14691. }
  14692.  
  14693. sub get_SEQUENCE_NUMBER {
  14694.     my $self = shift;
  14695.     return $self->[SEQUENCE_NUMBER];
  14696. }
  14697.  
  14698. sub get_INDEX {
  14699.     my $self = shift;
  14700.     return $self->[INDEX];
  14701. }
  14702.  
  14703. sub get_STARTING_INDEX {
  14704.     my $self = shift;
  14705.     return $self->[STARTING_INDEX];
  14706. }
  14707.  
  14708. sub set_HAVE_CHILD {
  14709.     my ( $self, $value ) = @_;
  14710.     if ( defined($value) ) {
  14711.         $self->[HAVE_CHILD] = $value;
  14712.     }
  14713.     return $self->[HAVE_CHILD];
  14714. }
  14715.  
  14716. sub get_HAVE_CHILD {
  14717.     my $self = shift;
  14718.     return $self->[HAVE_CHILD];
  14719. }
  14720.  
  14721. sub set_ARROW_COUNT {
  14722.     my ( $self, $value ) = @_;
  14723.     if ( defined($value) ) {
  14724.         $self->[ARROW_COUNT] = $value;
  14725.     }
  14726.     return $self->[ARROW_COUNT];
  14727. }
  14728.  
  14729. sub get_ARROW_COUNT {
  14730.     my $self = shift;
  14731.     return $self->[ARROW_COUNT];
  14732. }
  14733.  
  14734. sub set_COMMA_COUNT {
  14735.     my ( $self, $value ) = @_;
  14736.     if ( defined($value) ) {
  14737.         $self->[COMMA_COUNT] = $value;
  14738.     }
  14739.     return $self->[COMMA_COUNT];
  14740. }
  14741.  
  14742. sub get_COMMA_COUNT {
  14743.     my $self = shift;
  14744.     return $self->[COMMA_COUNT];
  14745. }
  14746.  
  14747. sub set_CLOSED {
  14748.     my ( $self, $value ) = @_;
  14749.     if ( defined($value) ) {
  14750.         $self->[CLOSED] = $value;
  14751.     }
  14752.     return $self->[CLOSED];
  14753. }
  14754.  
  14755. sub get_CLOSED {
  14756.     my $self = shift;
  14757.     return $self->[CLOSED];
  14758. }
  14759.  
  14760. #####################################################################
  14761. #
  14762. # the Perl::Tidy::VerticalAligner::Line class supplies an object to
  14763. # contain a single output line
  14764. #
  14765. #####################################################################
  14766.  
  14767. package Perl::Tidy::VerticalAligner::Line;
  14768.  
  14769. {
  14770.  
  14771.     use strict;
  14772.     use Carp;
  14773.  
  14774.     use constant JMAX                      => 0;
  14775.     use constant JMAX_ORIGINAL_LINE        => 1;
  14776.     use constant RTOKENS                   => 2;
  14777.     use constant RFIELDS                   => 3;
  14778.     use constant RPATTERNS                 => 4;
  14779.     use constant INDENTATION               => 5;
  14780.     use constant LEADING_SPACE_COUNT       => 6;
  14781.     use constant OUTDENT_LONG_LINES        => 7;
  14782.     use constant LIST_TYPE                 => 8;
  14783.     use constant IS_HANGING_SIDE_COMMENT   => 9;
  14784.     use constant RALIGNMENTS               => 10;
  14785.     use constant MAXIMUM_LINE_LENGTH       => 11;
  14786.     use constant RVERTICAL_TIGHTNESS_FLAGS => 12;
  14787.  
  14788.     my %_index_map;
  14789.     $_index_map{jmax}                      = JMAX;
  14790.     $_index_map{jmax_original_line}        = JMAX_ORIGINAL_LINE;
  14791.     $_index_map{rtokens}                   = RTOKENS;
  14792.     $_index_map{rfields}                   = RFIELDS;
  14793.     $_index_map{rpatterns}                 = RPATTERNS;
  14794.     $_index_map{indentation}               = INDENTATION;
  14795.     $_index_map{leading_space_count}       = LEADING_SPACE_COUNT;
  14796.     $_index_map{outdent_long_lines}        = OUTDENT_LONG_LINES;
  14797.     $_index_map{list_type}                 = LIST_TYPE;
  14798.     $_index_map{is_hanging_side_comment}   = IS_HANGING_SIDE_COMMENT;
  14799.     $_index_map{ralignments}               = RALIGNMENTS;
  14800.     $_index_map{maximum_line_length}       = MAXIMUM_LINE_LENGTH;
  14801.     $_index_map{rvertical_tightness_flags} = RVERTICAL_TIGHTNESS_FLAGS;
  14802.  
  14803.     my @_default_data = ();
  14804.     $_default_data[JMAX]                      = undef;
  14805.     $_default_data[JMAX_ORIGINAL_LINE]        = undef;
  14806.     $_default_data[RTOKENS]                   = undef;
  14807.     $_default_data[RFIELDS]                   = undef;
  14808.     $_default_data[RPATTERNS]                 = undef;
  14809.     $_default_data[INDENTATION]               = undef;
  14810.     $_default_data[LEADING_SPACE_COUNT]       = undef;
  14811.     $_default_data[OUTDENT_LONG_LINES]        = undef;
  14812.     $_default_data[LIST_TYPE]                 = undef;
  14813.     $_default_data[IS_HANGING_SIDE_COMMENT]   = undef;
  14814.     $_default_data[RALIGNMENTS]               = [];
  14815.     $_default_data[MAXIMUM_LINE_LENGTH]       = undef;
  14816.     $_default_data[RVERTICAL_TIGHTNESS_FLAGS] = undef;
  14817.  
  14818.     {
  14819.  
  14820.         # methods to count object population
  14821.         my $_count = 0;
  14822.         sub get_count        { $_count; }
  14823.         sub _increment_count { ++$_count }
  14824.         sub _decrement_count { --$_count }
  14825.     }
  14826.  
  14827.     # Constructor may be called as a class method
  14828.     sub new {
  14829.         my ( $caller, %arg ) = @_;
  14830.         my $caller_is_obj = ref($caller);
  14831.         my $class = $caller_is_obj || $caller;
  14832.         no strict "refs";
  14833.         my $self = bless [], $class;
  14834.  
  14835.         $self->[RALIGNMENTS] = [];
  14836.  
  14837.         my $index;
  14838.         foreach ( keys %_index_map ) {
  14839.             $index = $_index_map{$_};
  14840.             if    ( exists $arg{$_} ) { $self->[$index] = $arg{$_} }
  14841.             elsif ($caller_is_obj)    { $self->[$index] = $caller->[$index] }
  14842.             else { $self->[$index] = $_default_data[$index] }
  14843.         }
  14844.  
  14845.         $self->_increment_count();
  14846.         return $self;
  14847.     }
  14848.  
  14849.     sub DESTROY {
  14850.         $_[0]->_decrement_count();
  14851.     }
  14852.  
  14853.     sub get_jmax                      { $_[0]->[JMAX] }
  14854.     sub get_jmax_original_line        { $_[0]->[JMAX_ORIGINAL_LINE] }
  14855.     sub get_rtokens                   { $_[0]->[RTOKENS] }
  14856.     sub get_rfields                   { $_[0]->[RFIELDS] }
  14857.     sub get_rpatterns                 { $_[0]->[RPATTERNS] }
  14858.     sub get_indentation               { $_[0]->[INDENTATION] }
  14859.     sub get_leading_space_count       { $_[0]->[LEADING_SPACE_COUNT] }
  14860.     sub get_outdent_long_lines        { $_[0]->[OUTDENT_LONG_LINES] }
  14861.     sub get_list_type                 { $_[0]->[LIST_TYPE] }
  14862.     sub get_is_hanging_side_comment   { $_[0]->[IS_HANGING_SIDE_COMMENT] }
  14863.     sub get_rvertical_tightness_flags { $_[0]->[RVERTICAL_TIGHTNESS_FLAGS] }
  14864.  
  14865.     sub set_column     { $_[0]->[RALIGNMENTS]->[ $_[1] ]->set_column( $_[2] ) }
  14866.     sub get_alignment  { $_[0]->[RALIGNMENTS]->[ $_[1] ] }
  14867.     sub get_alignments { @{ $_[0]->[RALIGNMENTS] } }
  14868.     sub get_column     { $_[0]->[RALIGNMENTS]->[ $_[1] ]->get_column() }
  14869.  
  14870.     sub get_starting_column {
  14871.         $_[0]->[RALIGNMENTS]->[ $_[1] ]->get_starting_column();
  14872.     }
  14873.  
  14874.     sub increment_column {
  14875.         $_[0]->[RALIGNMENTS]->[ $_[1] ]->increment_column( $_[2] );
  14876.     }
  14877.     sub set_alignments { my $self = shift; @{ $self->[RALIGNMENTS] } = @_; }
  14878.  
  14879.     sub current_field_width {
  14880.         my $self = shift;
  14881.         my ($j) = @_;
  14882.         if ( $j == 0 ) {
  14883.             return $self->get_column($j);
  14884.         }
  14885.         else {
  14886.             return $self->get_column($j) - $self->get_column( $j - 1 );
  14887.         }
  14888.     }
  14889.  
  14890.     sub field_width_growth {
  14891.         my $self = shift;
  14892.         my $j    = shift;
  14893.         return $self->get_column($j) - $self->get_starting_column($j);
  14894.     }
  14895.  
  14896.     sub starting_field_width {
  14897.         my $self = shift;
  14898.         my $j    = shift;
  14899.         if ( $j == 0 ) {
  14900.             return $self->get_starting_column($j);
  14901.         }
  14902.         else {
  14903.             return $self->get_starting_column($j) -
  14904.               $self->get_starting_column( $j - 1 );
  14905.         }
  14906.     }
  14907.  
  14908.     sub increase_field_width {
  14909.  
  14910.         my $self = shift;
  14911.         my ( $j, $pad ) = @_;
  14912.         my $jmax = $self->get_jmax();
  14913.         for my $k ( $j .. $jmax ) {
  14914.             $self->increment_column( $k, $pad );
  14915.         }
  14916.     }
  14917.  
  14918.     sub get_available_space_on_right {
  14919.         my $self = shift;
  14920.         my $jmax = $self->get_jmax();
  14921.         return $self->[MAXIMUM_LINE_LENGTH] - $self->get_column($jmax);
  14922.     }
  14923.  
  14924.     sub set_jmax                    { $_[0]->[JMAX]                    = $_[1] }
  14925.     sub set_jmax_original_line      { $_[0]->[JMAX_ORIGINAL_LINE]      = $_[1] }
  14926.     sub set_rtokens                 { $_[0]->[RTOKENS]                 = $_[1] }
  14927.     sub set_rfields                 { $_[0]->[RFIELDS]                 = $_[1] }
  14928.     sub set_rpatterns               { $_[0]->[RPATTERNS]               = $_[1] }
  14929.     sub set_indentation             { $_[0]->[INDENTATION]             = $_[1] }
  14930.     sub set_leading_space_count     { $_[0]->[LEADING_SPACE_COUNT]     = $_[1] }
  14931.     sub set_outdent_long_lines      { $_[0]->[OUTDENT_LONG_LINES]      = $_[1] }
  14932.     sub set_list_type               { $_[0]->[LIST_TYPE]               = $_[1] }
  14933.     sub set_is_hanging_side_comment { $_[0]->[IS_HANGING_SIDE_COMMENT] = $_[1] }
  14934.     sub set_alignment               { $_[0]->[RALIGNMENTS]->[ $_[1] ]  = $_[2] }
  14935.  
  14936. }
  14937.  
  14938. #####################################################################
  14939. #
  14940. # the Perl::Tidy::VerticalAligner::Alignment class holds information
  14941. # on a single column being aligned
  14942. #
  14943. #####################################################################
  14944. package Perl::Tidy::VerticalAligner::Alignment;
  14945.  
  14946. {
  14947.  
  14948.     use strict;
  14949.  
  14950.     #use Carp;
  14951.  
  14952.     # Symbolic array indexes
  14953.     use constant COLUMN          => 0;    # the current column number
  14954.     use constant STARTING_COLUMN => 1;    # column number when created
  14955.     use constant MATCHING_TOKEN  => 2;    # what token we are matching
  14956.     use constant STARTING_LINE   => 3;    # the line index of creation
  14957.     use constant ENDING_LINE     => 4;    # the most recent line to use it
  14958.     use constant SAVED_COLUMN    => 5;    # the most recent line to use it
  14959.     use constant SERIAL_NUMBER   => 6;    # unique number for this alignment
  14960.                                           # (just its index in an array)
  14961.  
  14962.     # Correspondence between variables and array indexes
  14963.     my %_index_map;
  14964.     $_index_map{column}          = COLUMN;
  14965.     $_index_map{starting_column} = STARTING_COLUMN;
  14966.     $_index_map{matching_token}  = MATCHING_TOKEN;
  14967.     $_index_map{starting_line}   = STARTING_LINE;
  14968.     $_index_map{ending_line}     = ENDING_LINE;
  14969.     $_index_map{saved_column}    = SAVED_COLUMN;
  14970.     $_index_map{serial_number}   = SERIAL_NUMBER;
  14971.  
  14972.     my @_default_data = ();
  14973.     $_default_data[COLUMN]          = undef;
  14974.     $_default_data[STARTING_COLUMN] = undef;
  14975.     $_default_data[MATCHING_TOKEN]  = undef;
  14976.     $_default_data[STARTING_LINE]   = undef;
  14977.     $_default_data[ENDING_LINE]     = undef;
  14978.     $_default_data[SAVED_COLUMN]    = undef;
  14979.     $_default_data[SERIAL_NUMBER]   = undef;
  14980.  
  14981.     # class population count
  14982.     {
  14983.         my $_count = 0;
  14984.         sub get_count        { $_count; }
  14985.         sub _increment_count { ++$_count }
  14986.         sub _decrement_count { --$_count }
  14987.     }
  14988.  
  14989.     # constructor
  14990.     sub new {
  14991.         my ( $caller, %arg ) = @_;
  14992.         my $caller_is_obj = ref($caller);
  14993.         my $class = $caller_is_obj || $caller;
  14994.         no strict "refs";
  14995.         my $self = bless [], $class;
  14996.  
  14997.         foreach ( keys %_index_map ) {
  14998.             my $index = $_index_map{$_};
  14999.             if    ( exists $arg{$_} ) { $self->[$index] = $arg{$_} }
  15000.             elsif ($caller_is_obj)    { $self->[$index] = $caller->[$index] }
  15001.             else { $self->[$index] = $_default_data[$index] }
  15002.         }
  15003.         $self->_increment_count();
  15004.         return $self;
  15005.     }
  15006.  
  15007.     sub DESTROY {
  15008.         $_[0]->_decrement_count();
  15009.     }
  15010.  
  15011.     sub get_column          { return $_[0]->[COLUMN] }
  15012.     sub get_starting_column { return $_[0]->[STARTING_COLUMN] }
  15013.     sub get_matching_token  { return $_[0]->[MATCHING_TOKEN] }
  15014.     sub get_starting_line   { return $_[0]->[STARTING_LINE] }
  15015.     sub get_ending_line     { return $_[0]->[ENDING_LINE] }
  15016.     sub get_serial_number   { return $_[0]->[SERIAL_NUMBER] }
  15017.  
  15018.     sub set_column          { $_[0]->[COLUMN]          = $_[1] }
  15019.     sub set_starting_column { $_[0]->[STARTING_COLUMN] = $_[1] }
  15020.     sub set_matching_token  { $_[0]->[MATCHING_TOKEN]  = $_[1] }
  15021.     sub set_starting_line   { $_[0]->[STARTING_LINE]   = $_[1] }
  15022.     sub set_ending_line     { $_[0]->[ENDING_LINE]     = $_[1] }
  15023.     sub increment_column { $_[0]->[COLUMN] += $_[1] }
  15024.  
  15025.     sub save_column    { $_[0]->[SAVED_COLUMN] = $_[0]->[COLUMN] }
  15026.     sub restore_column { $_[0]->[COLUMN]       = $_[0]->[SAVED_COLUMN] }
  15027.  
  15028. }
  15029.  
  15030. package Perl::Tidy::VerticalAligner;
  15031.  
  15032. # The Perl::Tidy::VerticalAligner package collects output lines and
  15033. # attempts to line up certain common tokens, such as => and #, which are
  15034. # identified by the calling routine.
  15035. #
  15036. # There are two main routines: append_line and flush.  Append acts as a
  15037. # storage buffer, collecting lines into a group which can be vertically
  15038. # aligned.  When alignment is no longer possible or desirable, it dumps
  15039. # the group to flush.
  15040. #
  15041. #     append_line -----> flush
  15042. #
  15043. #     collects          writes
  15044. #     vertical          one
  15045. #     groups            group
  15046.  
  15047. BEGIN {
  15048.  
  15049.     # Caution: these debug flags produce a lot of output
  15050.     # They should all be 0 except when debugging small scripts
  15051.  
  15052.     use constant VALIGN_DEBUG_FLAG_APPEND  => 0;
  15053.     use constant VALIGN_DEBUG_FLAG_APPEND0 => 0;
  15054.  
  15055.     my $debug_warning = sub {
  15056.         print "VALIGN_DEBUGGING with key $_[0]\n";
  15057.     };
  15058.  
  15059.     VALIGN_DEBUG_FLAG_APPEND  && $debug_warning->('APPEND');
  15060.     VALIGN_DEBUG_FLAG_APPEND0 && $debug_warning->('APPEND0');
  15061.  
  15062. }
  15063.  
  15064. use vars qw(
  15065.   $vertical_aligner_self
  15066.   $current_line
  15067.   $maximum_alignment_index
  15068.   $ralignment_list
  15069.   $maximum_jmax_seen
  15070.   $minimum_jmax_seen
  15071.   $previous_minimum_jmax_seen
  15072.   $previous_maximum_jmax_seen
  15073.   $maximum_line_index
  15074.   $group_level
  15075.   $group_type
  15076.   $group_maximum_gap
  15077.   $marginal_match
  15078.   $last_group_level_written
  15079.   $extra_indent_ok
  15080.   $zero_count
  15081.   @group_lines
  15082.   $last_comment_column
  15083.   $last_side_comment_line_number
  15084.   $last_side_comment_length
  15085.   $last_side_comment_level
  15086.   $outdented_line_count
  15087.   $first_outdented_line_at
  15088.   $last_outdented_line_at
  15089.   $diagnostics_object
  15090.   $logger_object
  15091.   $file_writer_object
  15092.   @side_comment_history
  15093.   $comment_leading_space_count
  15094.  
  15095.   $cached_line_text
  15096.   $cached_line_type
  15097.   $cached_line_flag
  15098.   $cached_seqno
  15099.   $cached_line_valid
  15100.  
  15101.   $rOpts
  15102.  
  15103.   $rOpts_maximum_line_length
  15104.   $rOpts_continuation_indentation
  15105.   $rOpts_indent_columns
  15106.   $rOpts_tabs
  15107.   $rOpts_entab_leading_whitespace
  15108.  
  15109.   $rOpts_minimum_space_to_comment
  15110.  
  15111. );
  15112.  
  15113. sub initialize {
  15114.  
  15115.     my $class;
  15116.  
  15117.     ( $class, $rOpts, $file_writer_object, $logger_object, $diagnostics_object )
  15118.       = @_;
  15119.  
  15120.     # variables describing the entire space group:
  15121.  
  15122.     $ralignment_list            = [];
  15123.     $group_level                = 0;
  15124.     $last_group_level_written   = -1;
  15125.     $extra_indent_ok            = 0;    # can we move all lines to the right?
  15126.     $last_side_comment_length   = 0;
  15127.     $maximum_jmax_seen          = 0;
  15128.     $minimum_jmax_seen          = 0;
  15129.     $previous_minimum_jmax_seen = 0;
  15130.     $previous_maximum_jmax_seen = 0;
  15131.  
  15132.     # variables describing each line of the group
  15133.     @group_lines = ();                  # list of all lines in group
  15134.  
  15135.     $outdented_line_count          = 0;
  15136.     $first_outdented_line_at       = 0;
  15137.     $last_outdented_line_at        = 0;
  15138.     $last_side_comment_line_number = 0;
  15139.     $last_side_comment_level       = -1;
  15140.  
  15141.     # most recent 3 side comments; [ line number, column ]
  15142.     $side_comment_history[0] = [ -300, 0 ];
  15143.     $side_comment_history[1] = [ -200, 0 ];
  15144.     $side_comment_history[2] = [ -100, 0 ];
  15145.  
  15146.     # write_leader_and_string cache:
  15147.     $cached_line_text  = "";
  15148.     $cached_line_type  = 0;
  15149.     $cached_line_flag  = 0;
  15150.     $cached_seqno      = 0;
  15151.     $cached_line_valid = 0;
  15152.  
  15153.     # frequently used parameters
  15154.     $rOpts_indent_columns           = $rOpts->{'indent-columns'};
  15155.     $rOpts_tabs                     = $rOpts->{'tabs'};
  15156.     $rOpts_entab_leading_whitespace = $rOpts->{'entab-leading-whitespace'};
  15157.     $rOpts_minimum_space_to_comment = $rOpts->{'minimum-space-to-comment'};
  15158.     $rOpts_maximum_line_length      = $rOpts->{'maximum-line-length'};
  15159.  
  15160.     forget_side_comment();
  15161.  
  15162.     initialize_for_new_group();
  15163.  
  15164.     $vertical_aligner_self = {};
  15165.     bless $vertical_aligner_self, $class;
  15166.     return $vertical_aligner_self;
  15167. }
  15168.  
  15169. sub initialize_for_new_group {
  15170.     $maximum_line_index      = -1;      # lines in the current group
  15171.     $maximum_alignment_index = -1;      # alignments in current group
  15172.     $zero_count              = 0;       # count consecutive lines without tokens
  15173.     $current_line            = undef;   # line being matched for alignment
  15174.     $group_maximum_gap       = 0;       # largest gap introduced
  15175.     $group_type              = "";
  15176.     $marginal_match          = 0;
  15177.     $comment_leading_space_count = 0;
  15178. }
  15179.  
  15180. # interface to Perl::Tidy::Diagnostics routines
  15181. sub write_diagnostics {
  15182.     if ($diagnostics_object) {
  15183.         $diagnostics_object->write_diagnostics(@_);
  15184.     }
  15185. }
  15186.  
  15187. # interface to Perl::Tidy::Logger routines
  15188. sub warning {
  15189.     if ($logger_object) {
  15190.         $logger_object->warning(@_);
  15191.     }
  15192. }
  15193.  
  15194. sub write_logfile_entry {
  15195.     if ($logger_object) {
  15196.         $logger_object->write_logfile_entry(@_);
  15197.     }
  15198. }
  15199.  
  15200. sub report_definite_bug {
  15201.     if ($logger_object) {
  15202.         $logger_object->report_definite_bug();
  15203.     }
  15204. }
  15205.  
  15206. sub get_SPACES {
  15207.  
  15208.     # return the number of leading spaces associated with an indentation
  15209.     # variable $indentation is either a constant number of spaces or an
  15210.     # object with a get_SPACES method.
  15211.     my $indentation = shift;
  15212.     return ref($indentation) ? $indentation->get_SPACES() : $indentation;
  15213. }
  15214.  
  15215. sub get_RECOVERABLE_SPACES {
  15216.  
  15217.     # return the number of spaces (+ means shift right, - means shift left)
  15218.     # that we would like to shift a group of lines with the same indentation
  15219.     # to get them to line up with their opening parens
  15220.     my $indentation = shift;
  15221.     return ref($indentation) ? $indentation->get_RECOVERABLE_SPACES() : 0;
  15222. }
  15223.  
  15224. sub get_STACK_DEPTH {
  15225.  
  15226.     my $indentation = shift;
  15227.     return ref($indentation) ? $indentation->get_STACK_DEPTH() : 0;
  15228. }
  15229.  
  15230. sub make_alignment {
  15231.     my ( $col, $token ) = @_;
  15232.  
  15233.     # make one new alignment at column $col which aligns token $token
  15234.     ++$maximum_alignment_index;
  15235.     my $alignment = new Perl::Tidy::VerticalAligner::Alignment(
  15236.         column          => $col,
  15237.         starting_column => $col,
  15238.         matching_token  => $token,
  15239.         starting_line   => $maximum_line_index,
  15240.         ending_line     => $maximum_line_index,
  15241.         serial_number   => $maximum_alignment_index,
  15242.     );
  15243.     $ralignment_list->[$maximum_alignment_index] = $alignment;
  15244.     return $alignment;
  15245. }
  15246.  
  15247. sub dump_alignments {
  15248.     print
  15249. "Current Alignments:\ni\ttoken\tstarting_column\tcolumn\tstarting_line\tending_line\n";
  15250.     for my $i ( 0 .. $maximum_alignment_index ) {
  15251.         my $column          = $ralignment_list->[$i]->get_column();
  15252.         my $starting_column = $ralignment_list->[$i]->get_starting_column();
  15253.         my $matching_token  = $ralignment_list->[$i]->get_matching_token();
  15254.         my $starting_line   = $ralignment_list->[$i]->get_starting_line();
  15255.         my $ending_line     = $ralignment_list->[$i]->get_ending_line();
  15256.         print
  15257. "$i\t$matching_token\t$starting_column\t$column\t$starting_line\t$ending_line\n";
  15258.     }
  15259. }
  15260.  
  15261. sub save_alignment_columns {
  15262.     for my $i ( 0 .. $maximum_alignment_index ) {
  15263.         $ralignment_list->[$i]->save_column();
  15264.     }
  15265. }
  15266.  
  15267. sub restore_alignment_columns {
  15268.     for my $i ( 0 .. $maximum_alignment_index ) {
  15269.         $ralignment_list->[$i]->restore_column();
  15270.     }
  15271. }
  15272.  
  15273. sub forget_side_comment {
  15274.     $last_comment_column = 0;
  15275. }
  15276.  
  15277. sub append_line {
  15278.  
  15279.     # sub append is called to place one line in the current vertical group.
  15280.     #
  15281.     # The input parameters are:
  15282.     #     $level = indentation level of this line
  15283.     #     $rfields = reference to array of fields
  15284.     #     $rpatterns = reference to array of patterns, one per field
  15285.     #     $rtokens   = reference to array of tokens starting fields 1,2,..
  15286.     #
  15287.     # Here is an example of what this package does.  In this example,
  15288.     # we are trying to line up both the '=>' and the '#'.
  15289.     #
  15290.     #         '18' => 'grave',    #   \`
  15291.     #         '19' => 'acute',    #   `'
  15292.     #         '20' => 'caron',    #   \v
  15293.     # <-tabs-><f1-><--field 2 ---><-f3->
  15294.     # |            |              |    |
  15295.     # |            |              |    |
  15296.     # col1        col2         col3 col4
  15297.     #
  15298.     # The calling routine has already broken the entire line into 3 fields as
  15299.     # indicated.  (So the work of identifying promising common tokens has
  15300.     # already been done).
  15301.     #
  15302.     # In this example, there will be 2 tokens being matched: '=>' and '#'.
  15303.     # They are the leading parts of fields 2 and 3, but we do need to know
  15304.     # what they are so that we can dump a group of lines when these tokens
  15305.     # change.
  15306.     #
  15307.     # The fields contain the actual characters of each field.  The patterns
  15308.     # are like the fields, but they contain mainly token types instead
  15309.     # of tokens, so they have fewer characters.  They are used to be
  15310.     # sure we are matching fields of similar type.
  15311.     #
  15312.     # In this example, there will be 4 column indexes being adjusted.  The
  15313.     # first one is always at zero.  The interior columns are at the start of
  15314.     # the matching tokens, and the last one tracks the maximum line length.
  15315.     #
  15316.     # Basically, each time a new line comes in, it joins the current vertical
  15317.     # group if possible.  Otherwise it causes the current group to be dumped
  15318.     # and a new group is started.
  15319.     #
  15320.     # For each new group member, the column locations are increased, as
  15321.     # necessary, to make room for the new fields.  When the group is finally
  15322.     # output, these column numbers are used to compute the amount of spaces of
  15323.     # padding needed for each field.
  15324.     #
  15325.     # Programming note: the fields are assumed not to have any tab characters.
  15326.     # Tabs have been previously removed except for tabs in quoted strings and
  15327.     # side comments.  Tabs in these fields can mess up the column counting.
  15328.     # The log file warns the user if there are any such tabs.
  15329.  
  15330.     my (
  15331.         $level,                     $level_end,
  15332.         $indentation,               $rfields,
  15333.         $rtokens,                   $rpatterns,
  15334.         $is_forced_break,           $outdent_long_lines,
  15335.         $is_terminal_statement,     $do_not_pad,
  15336.         $rvertical_tightness_flags, $level_jump,
  15337.       )
  15338.       = @_;
  15339.  
  15340.     my $leading_space_count = get_SPACES($indentation);
  15341.  
  15342.     # number of fields is $jmax
  15343.     # number of tokens between fields is $jmax-1
  15344.     my $jmax = $#{$rfields};
  15345.     $previous_minimum_jmax_seen = $minimum_jmax_seen;
  15346.     $previous_maximum_jmax_seen = $maximum_jmax_seen;
  15347.  
  15348.     VALIGN_DEBUG_FLAG_APPEND0 && do {
  15349.         print
  15350. "APPEND0: entering lines=$maximum_line_index new #fields= $jmax, leading_count=$leading_space_count last_cmt=$last_comment_column force=$is_forced_break\n";
  15351.     };
  15352.  
  15353.     # Validate cached line if necessary: If we can produce a container
  15354.     # with just 2 lines total by combining an existing cached opening
  15355.     # token with the closing token to follow, then we will mark both
  15356.     # cached flags as valid.
  15357.     if ($rvertical_tightness_flags) {
  15358.         if (   $maximum_line_index <= 0
  15359.             && $cached_line_type
  15360.             && $rvertical_tightness_flags->[2] == $cached_seqno )
  15361.         {
  15362.             $rvertical_tightness_flags->[3] ||= 1;
  15363.             $cached_line_valid              ||= 1;
  15364.         }
  15365.     }
  15366.  
  15367.     # do not join an opening block brace with an unbalanced line
  15368.     # unless requested with a flag value of 2
  15369.     if (   $cached_line_type == 3
  15370.         && $maximum_line_index < 0
  15371.         && $cached_line_flag < 2
  15372.         && $level_jump != 0 )
  15373.     {
  15374.         $cached_line_valid = 0;
  15375.     }
  15376.  
  15377.     # patch until new aligner is finished
  15378.     if ($do_not_pad) { my_flush() }
  15379.  
  15380.     # shouldn't happen:
  15381.     if ( $level < 0 ) { $level = 0 }
  15382.  
  15383.     # do not align code across indentation level changes
  15384.     if ( $level != $group_level ) {
  15385.  
  15386.         # we are allowed to shift a group of lines to the right if its
  15387.         # level is greater than the previous and next group
  15388.         $extra_indent_ok =
  15389.           ( $level < $group_level && $last_group_level_written < $group_level );
  15390.  
  15391.         my_flush();
  15392.  
  15393.         # If we know that this line will get flushed out by itself because
  15394.         # of level changes, we can leave the extra_indent_ok flag set.
  15395.         # That way, if we get an external flush call, we will still be
  15396.         # able to do some -lp alignment if necessary.
  15397.         $extra_indent_ok = ( $is_terminal_statement && $level > $group_level );
  15398.  
  15399.         $group_level = $level;
  15400.  
  15401.         # wait until after the above flush to get the leading space
  15402.         # count because it may have been changed if the -icp flag is in
  15403.         # effect
  15404.         $leading_space_count = get_SPACES($indentation);
  15405.  
  15406.     }
  15407.  
  15408.     # --------------------------------------------------------------------
  15409.     # Patch to collect outdentable block COMMENTS
  15410.     # --------------------------------------------------------------------
  15411.     my $is_blank_line = "";
  15412.     my $is_block_comment = ( $jmax == 0 && $rfields->[0] =~ /^#/ );
  15413.     if ( $group_type eq 'COMMENT' ) {
  15414.         if (
  15415.             (
  15416.                    $is_block_comment
  15417.                 && $outdent_long_lines
  15418.                 && $leading_space_count == $comment_leading_space_count
  15419.             )
  15420.             || $is_blank_line
  15421.           )
  15422.         {
  15423.             $group_lines[ ++$maximum_line_index ] = $rfields->[0];
  15424.             return;
  15425.         }
  15426.         else {
  15427.             my_flush();
  15428.         }
  15429.     }
  15430.  
  15431.     # --------------------------------------------------------------------
  15432.     # Step 1. Handle simple line of code with no fields to match.
  15433.     # --------------------------------------------------------------------
  15434.     if ( $jmax <= 0 ) {
  15435.         $zero_count++;
  15436.  
  15437.         if ( $maximum_line_index >= 0
  15438.             && !get_RECOVERABLE_SPACES( $group_lines[0]->get_indentation() ) )
  15439.         {
  15440.  
  15441.             # flush the current group if it has some aligned columns..
  15442.             if ( $group_lines[0]->get_jmax() > 1 ) { my_flush() }
  15443.  
  15444.             # flush current group if we are just collecting side comments..
  15445.             elsif (
  15446.  
  15447.                 # ...and we haven't seen a comment lately
  15448.                 ( $zero_count > 3 )
  15449.  
  15450.                 # ..or if this new line doesn't fit to the left of the comments
  15451.                 || ( ( $leading_space_count + length( $$rfields[0] ) ) >
  15452.                     $group_lines[0]->get_column(0) )
  15453.               )
  15454.             {
  15455.                 my_flush();
  15456.             }
  15457.         }
  15458.  
  15459.         # patch to start new COMMENT group if this comment may be outdented
  15460.         if (   $is_block_comment
  15461.             && $outdent_long_lines
  15462.             && $maximum_line_index < 0 )
  15463.         {
  15464.             $group_type                           = 'COMMENT';
  15465.             $comment_leading_space_count          = $leading_space_count;
  15466.             $group_lines[ ++$maximum_line_index ] = $rfields->[0];
  15467.             return;
  15468.         }
  15469.  
  15470.         # just write this line directly if no current group, no side comment,
  15471.         # and no space recovery is needed.
  15472.         if ( $maximum_line_index < 0 && !get_RECOVERABLE_SPACES($indentation) )
  15473.         {
  15474.             write_leader_and_string( $leading_space_count, $$rfields[0], 0,
  15475.                 $outdent_long_lines, $rvertical_tightness_flags );
  15476.             return;
  15477.         }
  15478.     }
  15479.     else {
  15480.         $zero_count = 0;
  15481.     }
  15482.  
  15483.     # programming check: (shouldn't happen)
  15484.     # an error here implies an incorrect call was made
  15485.     if ( $jmax > 0 && ( $#{$rtokens} != ( $jmax - 1 ) ) ) {
  15486.         warning(
  15487. "Program bug in Perl::Tidy::VerticalAligner - number of tokens = $#{$rtokens} should be one less than number of fields: $#{$rfields})\n"
  15488.         );
  15489.         report_definite_bug();
  15490.     }
  15491.  
  15492.     # --------------------------------------------------------------------
  15493.     # create an object to hold this line
  15494.     # --------------------------------------------------------------------
  15495.     my $is_hanging_side_comment = 0;
  15496.     my $new_line                = new Perl::Tidy::VerticalAligner::Line(
  15497.         jmax                      => $jmax,
  15498.         jmax_original_line        => $jmax,
  15499.         rtokens                   => $rtokens,
  15500.         rfields                   => $rfields,
  15501.         rpatterns                 => $rpatterns,
  15502.         indentation               => $indentation,
  15503.         leading_space_count       => $leading_space_count,
  15504.         outdent_long_lines        => $outdent_long_lines,
  15505.         list_type                 => "",
  15506.         is_hanging_side_comment   => $is_hanging_side_comment,
  15507.         maximum_line_length       => $rOpts->{'maximum-line-length'},
  15508.         rvertical_tightness_flags => $rvertical_tightness_flags,
  15509.     );
  15510.  
  15511.     # --------------------------------------------------------------------
  15512.     # It simplifies things to create a zero length side comment
  15513.     # if none exists.
  15514.     # --------------------------------------------------------------------
  15515.     make_side_comment( $new_line, $level_end );
  15516.  
  15517.     # --------------------------------------------------------------------
  15518.     # Decide if this is a simple list of items.
  15519.     # There are 3 list types: none, comma, comma-arrow.
  15520.     # We use this below to be less restrictive in deciding what to align.
  15521.     # --------------------------------------------------------------------
  15522.     if ($is_forced_break) {
  15523.         decide_if_list($new_line);
  15524.     }
  15525.  
  15526.     if ($current_line) {
  15527.  
  15528.         # --------------------------------------------------------------------
  15529.         # Allow hanging side comment to join current group, if any
  15530.         # This will help keep side comments aligned, because otherwise we
  15531.         # will have to start a new group, making alignment less likely.
  15532.         # --------------------------------------------------------------------
  15533.         $is_hanging_side_comment =
  15534.           hanging_comment_check( $new_line, $current_line );
  15535.  
  15536.         # --------------------------------------------------------------------
  15537.         # If there is just one previous line, and it has more fields
  15538.         # than the new line, try to join fields together to get a match with
  15539.         # the new line.  At the present time, only a single leading '=' is
  15540.         # allowed to be compressed out.  This is useful in rare cases where
  15541.         # a table is forced to use old breakpoints because of side comments,
  15542.         # and the table starts out something like this:
  15543.         #   my %MonthChars = ('0', 'Jan',   # side comment
  15544.         #                     '1', 'Feb',
  15545.         #                     '2', 'Mar',
  15546.         # Eliminating the '=' field will allow the remaining fields to line up.
  15547.         # This situation does not occur if there are no side comments
  15548.         # because scan_list would put a break after the opening '('.
  15549.         # --------------------------------------------------------------------
  15550.         eliminate_old_fields( $new_line, $current_line );
  15551.  
  15552.         # --------------------------------------------------------------------
  15553.         # If the new line has more fields than the current group,
  15554.         # see if we can match the first fields and combine the remaining
  15555.         # fields of the new line.
  15556.         # --------------------------------------------------------------------
  15557.         eliminate_new_fields( $new_line, $current_line );
  15558.  
  15559.         # --------------------------------------------------------------------
  15560.         # Flush previous group unless all common tokens and patterns match..
  15561.         # --------------------------------------------------------------------
  15562.         check_match( $new_line, $current_line );
  15563.  
  15564.         # --------------------------------------------------------------------
  15565.         # See if there is space for this line in the current group (if any)
  15566.         # --------------------------------------------------------------------
  15567.         if ($current_line) {
  15568.             check_fit( $new_line, $current_line );
  15569.         }
  15570.     }
  15571.  
  15572.     # --------------------------------------------------------------------
  15573.     # Append this line to the current group (or start new group)
  15574.     # --------------------------------------------------------------------
  15575.     accept_line($new_line);
  15576.  
  15577.     # Future update to allow this to vary:
  15578.     $current_line = $new_line if ( $maximum_line_index == 0 );
  15579.  
  15580.     # --------------------------------------------------------------------
  15581.     # Step 8. Some old debugging stuff
  15582.     # --------------------------------------------------------------------
  15583.     VALIGN_DEBUG_FLAG_APPEND && do {
  15584.         print "APPEND fields:";
  15585.         dump_array(@$rfields);
  15586.         print "APPEND tokens:";
  15587.         dump_array(@$rtokens);
  15588.         print "APPEND patterns:";
  15589.         dump_array(@$rpatterns);
  15590.         dump_alignments();
  15591.     };
  15592. }
  15593.  
  15594. sub hanging_comment_check {
  15595.  
  15596.     my $line = shift;
  15597.     my $jmax = $line->get_jmax();
  15598.     return 0 unless $jmax == 1;    # must be 2 fields
  15599.     my $rtokens = $line->get_rtokens();
  15600.     return 0 unless $$rtokens[0] eq '#';    # the second field is a comment..
  15601.     my $rfields = $line->get_rfields();
  15602.     return 0 unless $$rfields[0] =~ /^\s*$/;    # the first field is empty...
  15603.     my $old_line            = shift;
  15604.     my $maximum_field_index = $old_line->get_jmax();
  15605.     return 0
  15606.       unless $maximum_field_index > $jmax;    # the current line has more fields
  15607.     my $rpatterns = $line->get_rpatterns();
  15608.  
  15609.     $line->set_is_hanging_side_comment(1);
  15610.     $jmax = $maximum_field_index;
  15611.     $line->set_jmax($jmax);
  15612.     $$rfields[$jmax]         = $$rfields[1];
  15613.     $$rtokens[ $jmax - 1 ]   = $$rtokens[0];
  15614.     $$rpatterns[ $jmax - 1 ] = $$rpatterns[0];
  15615.     for ( my $j = 1 ; $j < $jmax ; $j++ ) {
  15616.         $$rfields[$j]         = " ";  # NOTE: caused glitch unless 1 blank, why?
  15617.         $$rtokens[ $j - 1 ]   = "";
  15618.         $$rpatterns[ $j - 1 ] = "";
  15619.     }
  15620.     return 1;
  15621. }
  15622.  
  15623. sub eliminate_old_fields {
  15624.  
  15625.     my $new_line = shift;
  15626.     my $jmax     = $new_line->get_jmax();
  15627.     if ( $jmax > $maximum_jmax_seen ) { $maximum_jmax_seen = $jmax }
  15628.     if ( $jmax < $minimum_jmax_seen ) { $minimum_jmax_seen = $jmax }
  15629.  
  15630.     # there must be one previous line
  15631.     return unless ( $maximum_line_index == 0 );
  15632.  
  15633.     my $old_line            = shift;
  15634.     my $maximum_field_index = $old_line->get_jmax();
  15635.  
  15636.     # this line must have fewer fields
  15637.     return unless $maximum_field_index > $jmax;
  15638.  
  15639.     # Identify specific cases where field elimination is allowed:
  15640.     # case=1: both lines have comma-separated lists, and the first
  15641.     #         line has an equals
  15642.     # case=2: both lines have leading equals
  15643.  
  15644.     # case 1 is the default
  15645.     my $case = 1;
  15646.  
  15647.     # See if case 2: both lines have leading '='
  15648.     # We'll require smiliar leading patterns in this case
  15649.     my $old_rtokens   = $old_line->get_rtokens();
  15650.     my $rtokens       = $new_line->get_rtokens();
  15651.     my $rpatterns     = $new_line->get_rpatterns();
  15652.     my $old_rpatterns = $old_line->get_rpatterns();
  15653.     if (   $rtokens->[0] =~ /^=\d*$/
  15654.         && $old_rtokens->[0]   eq $rtokens->[0]
  15655.         && $old_rpatterns->[0] eq $rpatterns->[0] )
  15656.     {
  15657.         $case = 2;
  15658.     }
  15659.  
  15660.     # not too many fewer fields in new line for case 1
  15661.     return unless ( $case != 1 || $maximum_field_index - 2 <= $jmax );
  15662.  
  15663.     # case 1 must have side comment
  15664.     my $old_rfields = $old_line->get_rfields();
  15665.     return
  15666.       if ( $case == 1
  15667.         && length( $$old_rfields[$maximum_field_index] ) == 0 );
  15668.  
  15669.     my $rfields = $new_line->get_rfields();
  15670.  
  15671.     my $hid_equals = 0;
  15672.  
  15673.     my @new_alignments        = ();
  15674.     my @new_fields            = ();
  15675.     my @new_matching_patterns = ();
  15676.     my @new_matching_tokens   = ();
  15677.  
  15678.     my $j = 0;
  15679.     my $k;
  15680.     my $current_field   = '';
  15681.     my $current_pattern = '';
  15682.  
  15683.     # loop over all old tokens
  15684.     my $in_match = 0;
  15685.     for ( $k = 0 ; $k < $maximum_field_index ; $k++ ) {
  15686.         $current_field .= $$old_rfields[$k];
  15687.         $current_pattern .= $$old_rpatterns[$k];
  15688.         last if ( $j > $jmax - 1 );
  15689.  
  15690.         if ( $$old_rtokens[$k] eq $$rtokens[$j] ) {
  15691.             $in_match                  = 1;
  15692.             $new_fields[$j]            = $current_field;
  15693.             $new_matching_patterns[$j] = $current_pattern;
  15694.             $current_field             = '';
  15695.             $current_pattern           = '';
  15696.             $new_matching_tokens[$j]   = $$old_rtokens[$k];
  15697.             $new_alignments[$j]        = $old_line->get_alignment($k);
  15698.             $j++;
  15699.         }
  15700.         else {
  15701.  
  15702.             if ( $$old_rtokens[$k] =~ /^\=\d*$/ ) {
  15703.                 last if ( $case == 2 );    # avoid problems with stuff
  15704.                                            # like:   $a=$b=$c=$d;
  15705.                 $hid_equals = 1;
  15706.             }
  15707.             last
  15708.               if ( $in_match && $case == 1 )
  15709.               ;    # disallow gaps in matching field types in case 1
  15710.         }
  15711.     }
  15712.  
  15713.     # Modify the current state if we are successful.
  15714.     # We must exactly reach the ends of both lists for success.
  15715.     if (   ( $j == $jmax )
  15716.         && ( $current_field eq '' )
  15717.         && ( $case != 1 || $hid_equals ) )
  15718.     {
  15719.         $k = $maximum_field_index;
  15720.         $current_field .= $$old_rfields[$k];
  15721.         $current_pattern .= $$old_rpatterns[$k];
  15722.         $new_fields[$j]            = $current_field;
  15723.         $new_matching_patterns[$j] = $current_pattern;
  15724.  
  15725.         $new_alignments[$j] = $old_line->get_alignment($k);
  15726.         $maximum_field_index = $j;
  15727.  
  15728.         $old_line->set_alignments(@new_alignments);
  15729.         $old_line->set_jmax($jmax);
  15730.         $old_line->set_rtokens( \@new_matching_tokens );
  15731.         $old_line->set_rfields( \@new_fields );
  15732.         $old_line->set_rpatterns( \@$rpatterns );
  15733.     }
  15734. }
  15735.  
  15736. # create an empty side comment if none exists
  15737. sub make_side_comment {
  15738.     my $new_line  = shift;
  15739.     my $level_end = shift;
  15740.     my $jmax      = $new_line->get_jmax();
  15741.     my $rtokens   = $new_line->get_rtokens();
  15742.  
  15743.     # if line does not have a side comment...
  15744.     if ( ( $jmax == 0 ) || ( $$rtokens[ $jmax - 1 ] ne '#' ) ) {
  15745.         my $rfields   = $new_line->get_rfields();
  15746.         my $rpatterns = $new_line->get_rpatterns();
  15747.         $$rtokens[$jmax]     = '#';
  15748.         $$rfields[ ++$jmax ] = '';
  15749.         $$rpatterns[$jmax]   = '#';
  15750.         $new_line->set_jmax($jmax);
  15751.         $new_line->set_jmax_original_line($jmax);
  15752.     }
  15753.  
  15754.     # line has a side comment..
  15755.     else {
  15756.  
  15757.         # don't remember old side comment location for very long
  15758.         my $line_number = $vertical_aligner_self->get_output_line_number();
  15759.         my $rfields     = $new_line->get_rfields();
  15760.         if (
  15761.             $line_number - $last_side_comment_line_number > 12
  15762.  
  15763.             # and don't remember comment location across block level changes
  15764.             || ( $level_end < $last_side_comment_level && $$rfields[0] =~ /^}/ )
  15765.           )
  15766.         {
  15767.             forget_side_comment();
  15768.         }
  15769.         $last_side_comment_line_number = $line_number;
  15770.         $last_side_comment_level       = $level_end;
  15771.     }
  15772. }
  15773.  
  15774. sub decide_if_list {
  15775.  
  15776.     my $line = shift;
  15777.  
  15778.     # A list will be taken to be a line with a forced break in which all
  15779.     # of the field separators are commas or comma-arrows (except for the
  15780.     # trailing #)
  15781.  
  15782.     # List separator tokens are things like ',3'   or '=>2',
  15783.     # where the trailing digit is the nesting depth.  Allow braces
  15784.     # to allow nested list items.
  15785.     my $rtokens    = $line->get_rtokens();
  15786.     my $test_token = $$rtokens[0];
  15787.     if ( $test_token =~ /^(\,|=>)/ ) {
  15788.         my $list_type = $test_token;
  15789.         my $jmax      = $line->get_jmax();
  15790.  
  15791.         foreach ( 1 .. $jmax - 2 ) {
  15792.             if ( $$rtokens[$_] !~ /^(\,|=>|\{)/ ) {
  15793.                 $list_type = "";
  15794.                 last;
  15795.             }
  15796.         }
  15797.         $line->set_list_type($list_type);
  15798.     }
  15799. }
  15800.  
  15801. sub eliminate_new_fields {
  15802.  
  15803.     return unless ( $maximum_line_index >= 0 );
  15804.     my $new_line = shift;
  15805.     my $old_line = shift;
  15806.     my $jmax     = $new_line->get_jmax();
  15807.  
  15808.     my $old_rtokens   = $old_line->get_rtokens();
  15809.     my $rtokens       = $new_line->get_rtokens();
  15810.     my $is_assignment =
  15811.       ( $rtokens->[0] =~ /^=\d*$/ && ( $old_rtokens->[0] eq $rtokens->[0] ) );
  15812.  
  15813.     # must be monotonic variation
  15814.     return unless ( $is_assignment || $previous_maximum_jmax_seen <= $jmax );
  15815.  
  15816.     # must be more fields in the new line
  15817.     my $maximum_field_index = $old_line->get_jmax();
  15818.     return unless ( $maximum_field_index < $jmax );
  15819.  
  15820.     unless ($is_assignment) {
  15821.         return
  15822.           unless ( $old_line->get_jmax_original_line() == $minimum_jmax_seen )
  15823.           ;    # only if monotonic
  15824.  
  15825.         # never combine fields of a comma list
  15826.         return
  15827.           unless ( $maximum_field_index > 1 )
  15828.           && ( $new_line->get_list_type() !~ /^,/ );
  15829.     }
  15830.  
  15831.     my $rfields       = $new_line->get_rfields();
  15832.     my $rpatterns     = $new_line->get_rpatterns();
  15833.     my $old_rpatterns = $old_line->get_rpatterns();
  15834.  
  15835.     # loop over all old tokens except comment
  15836.     my $match = 1;
  15837.     my $k;
  15838.     for ( $k = 0 ; $k < $maximum_field_index - 1 ; $k++ ) {
  15839.         if (   ( $$old_rtokens[$k] ne $$rtokens[$k] )
  15840.             || ( $$old_rpatterns[$k] ne $$rpatterns[$k] ) )
  15841.         {
  15842.             $match = 0;
  15843.             last;
  15844.         }
  15845.     }
  15846.  
  15847.     # first tokens agree, so combine new tokens
  15848.     if ($match) {
  15849.         for $k ( $maximum_field_index .. $jmax - 1 ) {
  15850.  
  15851.             $$rfields[ $maximum_field_index - 1 ] .= $$rfields[$k];
  15852.             $$rfields[$k] = "";
  15853.             $$rpatterns[ $maximum_field_index - 1 ] .= $$rpatterns[$k];
  15854.             $$rpatterns[$k] = "";
  15855.         }
  15856.  
  15857.         $$rtokens[ $maximum_field_index - 1 ] = '#';
  15858.         $$rfields[$maximum_field_index]       = $$rfields[$jmax];
  15859.         $$rpatterns[$maximum_field_index]     = $$rpatterns[$jmax];
  15860.         $jmax                                 = $maximum_field_index;
  15861.     }
  15862.     $new_line->set_jmax($jmax);
  15863. }
  15864.  
  15865. sub check_match {
  15866.  
  15867.     my $new_line = shift;
  15868.     my $old_line = shift;
  15869.  
  15870.     my $jmax                = $new_line->get_jmax();
  15871.     my $maximum_field_index = $old_line->get_jmax();
  15872.  
  15873.     # flush if this line has too many fields
  15874.     if ( $jmax > $maximum_field_index ) { my_flush(); return }
  15875.  
  15876.     # flush if adding this line would make a non-monotonic field count
  15877.     if (
  15878.         ( $maximum_field_index > $jmax )    # this has too few fields
  15879.         && (
  15880.             ( $previous_minimum_jmax_seen < $jmax )  # and wouldn't be monotonic
  15881.             || ( $old_line->get_jmax_original_line() != $maximum_jmax_seen )
  15882.         )
  15883.       )
  15884.     {
  15885.         my_flush();
  15886.         return;
  15887.     }
  15888.  
  15889.     # otherwise append this line if everything matches
  15890.     my $jmax_original_line      = $new_line->get_jmax_original_line();
  15891.     my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
  15892.     my $rtokens                 = $new_line->get_rtokens();
  15893.     my $rfields                 = $new_line->get_rfields();
  15894.     my $rpatterns               = $new_line->get_rpatterns();
  15895.     my $list_type               = $new_line->get_list_type();
  15896.  
  15897.     my $group_list_type = $old_line->get_list_type();
  15898.     my $old_rpatterns   = $old_line->get_rpatterns();
  15899.     my $old_rtokens     = $old_line->get_rtokens();
  15900.  
  15901.     my $jlimit = $jmax - 1;
  15902.     if ( $maximum_field_index > $jmax ) {
  15903.         $jlimit = $jmax_original_line;
  15904.         --$jlimit unless ( length( $new_line->get_rfields()->[$jmax] ) );
  15905.     }
  15906.  
  15907.     my $everything_matches = 1;
  15908.  
  15909.     # common list types always match
  15910.     unless ( ( $group_list_type && ( $list_type eq $group_list_type ) )
  15911.         || $is_hanging_side_comment )
  15912.     {
  15913.  
  15914.         my $leading_space_count = $new_line->get_leading_space_count();
  15915.         my $saw_equals          = 0;
  15916.         for my $j ( 0 .. $jlimit ) {
  15917.             my $match = 1;
  15918.  
  15919.             my $old_tok = $$old_rtokens[$j];
  15920.             my $new_tok = $$rtokens[$j];
  15921.  
  15922.             # dumb down the match after an equals
  15923.             if ( $saw_equals && $new_tok =~ /(.*)\+/ ) {
  15924.                 $new_tok = $1;
  15925.                 $old_tok =~ s/\+.*$//;
  15926.             }
  15927.             if ( $new_tok =~ /^=\d*$/ ) { $saw_equals = 1 }
  15928.  
  15929.             # we never match if the matching tokens differ
  15930.             if (   $j < $jlimit
  15931.                 && $old_tok ne $new_tok )
  15932.             {
  15933.                 $match = 0;
  15934.             }
  15935.  
  15936.             # otherwise, if patterns match, we always have a match.
  15937.             # However, if patterns don't match, we have to be careful...
  15938.             elsif ( $$old_rpatterns[$j] ne $$rpatterns[$j] ) {
  15939.  
  15940.                 # We have to be very careful about aligning commas when the
  15941.                 # pattern's don't match, because it can be worse to create an
  15942.                 # alignment where none is needed than to omit one.  The current
  15943.                 # rule: if we are within a matching sub call (indicated by '+'
  15944.                 # in the matching token), we'll allow a marginal match, but
  15945.                 # otherwise not.
  15946.                 #
  15947.                 # Here's an example where we'd like to align the '='
  15948.                 #  my $cfile = File::Spec->catfile( 't',    'callext.c' );
  15949.                 #  my $inc   = File::Spec->catdir( 'Basic', 'Core' );
  15950.                 # because the function names differ.
  15951.                 # Future alignment logic should make this unnecessary.
  15952.                 #
  15953.                 # Here's an example where the ','s are not contained in a call.
  15954.                 # The first line below should probably not match the next two:
  15955.                 #   ( $a, $b ) = ( $b, $r );
  15956.                 #   ( $x1, $x2 ) = ( $x2 - $q * $x1, $x1 );
  15957.                 #   ( $y1, $y2 ) = ( $y2 - $q * $y1, $y1 );
  15958.                 if ( $new_tok =~ /^,/ ) {
  15959.                     if ( $$rtokens[$j] =~ /[A-Za-z]/ ) {
  15960.                         $marginal_match = 1;
  15961.                     }
  15962.                     else {
  15963.                         $match = 0;
  15964.                     }
  15965.                 }
  15966.  
  15967.                 # parens don't align well unless patterns match
  15968.                 elsif ( $new_tok =~ /^\(/ ) {
  15969.                     $match = 0;
  15970.                 }
  15971.  
  15972.                 # Handle an '=' alignment with different patterns to
  15973.                 # the left.
  15974.                 elsif ( $new_tok =~ /^=\d*$/ ) {
  15975.  
  15976.                     $saw_equals = 1;
  15977.  
  15978.                     # It is best to be a little restrictive when
  15979.                     # aligning '=' tokens.  Here is an example of
  15980.                     # two lines that we will not align:
  15981.                     #       my $variable=6;
  15982.                     #       $bb=4;
  15983.                     # The problem is that one is a 'my' declaration,
  15984.                     # and the other isn't, so they're not very similar.
  15985.                     # We will filter these out by comparing the first
  15986.                     # letter of the pattern.  This is crude, but works
  15987.                     # well enough.
  15988.                     if (
  15989.                         substr( $$old_rpatterns[$j], 0, 1 ) ne
  15990.                         substr( $$rpatterns[$j], 0, 1 ) )
  15991.                     {
  15992.                         $match = 0;
  15993.                     }
  15994.  
  15995.                     # If we pass that test, we'll call it a marginal match.
  15996.                     # Here is an example of a marginal match:
  15997.                     #       $done{$$op} = 1;
  15998.                     #       $op         = compile_bblock($op);
  15999.                     # The left tokens are both identifiers, but
  16000.                     # one accesses a hash and the other doesn't.
  16001.                     # We'll let this be a tentative match and undo
  16002.                     # it later if we don't find more than 2 lines
  16003.                     # in the group.
  16004.                     elsif ( $maximum_line_index == 0 ) {
  16005.                         $marginal_match = 1;
  16006.                     }
  16007.                 }
  16008.             }
  16009.  
  16010.             # Don't let line with fewer fields increase column widths
  16011.             # ( align3.t )
  16012.             if ( $maximum_field_index > $jmax ) {
  16013.                 my $pad =
  16014.                   length( $$rfields[$j] ) - $old_line->current_field_width($j);
  16015.  
  16016.                 if ( $j == 0 ) {
  16017.                     $pad += $leading_space_count;
  16018.                 }
  16019.  
  16020.                 # TESTING: suspend this rule to allow last lines to join
  16021.                 if ( $pad > 0 ) { $match = 0; }
  16022.             }
  16023.  
  16024.             unless ($match) {
  16025.                 $everything_matches = 0;
  16026.                 last;
  16027.             }
  16028.         }
  16029.     }
  16030.  
  16031.     if ( $maximum_field_index > $jmax ) {
  16032.  
  16033.         if ($everything_matches) {
  16034.  
  16035.             my $comment = $$rfields[$jmax];
  16036.             for $jmax ( $jlimit .. $maximum_field_index ) {
  16037.                 $$rtokens[$jmax]     = $$old_rtokens[$jmax];
  16038.                 $$rfields[ ++$jmax ] = '';
  16039.                 $$rpatterns[$jmax]   = $$old_rpatterns[$jmax];
  16040.             }
  16041.             $$rfields[$jmax] = $comment;
  16042.             $new_line->set_jmax($jmax);
  16043.         }
  16044.     }
  16045.  
  16046.     my_flush() unless ($everything_matches);
  16047. }
  16048.  
  16049. sub check_fit {
  16050.  
  16051.     return unless ( $maximum_line_index >= 0 );
  16052.     my $new_line = shift;
  16053.     my $old_line = shift;
  16054.  
  16055.     my $jmax                    = $new_line->get_jmax();
  16056.     my $leading_space_count     = $new_line->get_leading_space_count();
  16057.     my $is_hanging_side_comment = $new_line->get_is_hanging_side_comment();
  16058.     my $rtokens                 = $new_line->get_rtokens();
  16059.     my $rfields                 = $new_line->get_rfields();
  16060.     my $rpatterns               = $new_line->get_rpatterns();
  16061.  
  16062.     my $group_list_type = $group_lines[0]->get_list_type();
  16063.  
  16064.     my $padding_so_far    = 0;
  16065.     my $padding_available = $old_line->get_available_space_on_right();
  16066.  
  16067.     # save current columns in case this doesn't work
  16068.     save_alignment_columns();
  16069.  
  16070.     my ( $j, $pad, $eight );
  16071.     for $j ( 0 .. $jmax ) {
  16072.  
  16073.         $pad = length( $$rfields[$j] ) - $old_line->current_field_width($j);
  16074.  
  16075.         if ( $j == 0 ) {
  16076.             $pad += $leading_space_count;
  16077.         }
  16078.  
  16079.         # remember largest gap of the group, excluding gap to side comment
  16080.         if (   $pad < 0
  16081.             && $group_maximum_gap < -$pad
  16082.             && $j > 0
  16083.             && $j < $jmax - 1 )
  16084.         {
  16085.             $group_maximum_gap = -$pad;
  16086.         }
  16087.  
  16088.         next if $pad < 0;
  16089.  
  16090.         # This line will need space; lets see if we want to accept it..
  16091.         if (
  16092.  
  16093.             # not if this won't fit
  16094.             ( $pad > $padding_available )
  16095.  
  16096.             # previously, there were upper bounds placed on padding here
  16097.             # (maximum_whitespace_columns), but they were not really helpful
  16098.  
  16099.           )
  16100.         {
  16101.  
  16102.             # revert to starting state then flush; things didn't work out
  16103.             restore_alignment_columns();
  16104.             my_flush();
  16105.             last;
  16106.         }
  16107.  
  16108.         # looks ok, squeeze this field in
  16109.         $old_line->increase_field_width( $j, $pad );
  16110.         $padding_available -= $pad;
  16111.  
  16112.         # remember largest gap of the group, excluding gap to side comment
  16113.         if ( $pad > $group_maximum_gap && $j > 0 && $j < $jmax - 1 ) {
  16114.             $group_maximum_gap = $pad;
  16115.         }
  16116.     }
  16117. }
  16118.  
  16119. sub accept_line {
  16120.  
  16121.     my $new_line = shift;
  16122.     $group_lines[ ++$maximum_line_index ] = $new_line;
  16123.  
  16124.     # initialize field lengths if starting new group
  16125.     if ( $maximum_line_index == 0 ) {
  16126.  
  16127.         my $jmax    = $new_line->get_jmax();
  16128.         my $rfields = $new_line->get_rfields();
  16129.         my $rtokens = $new_line->get_rtokens();
  16130.         my $j;
  16131.         my $col = $new_line->get_leading_space_count();
  16132.  
  16133.         for $j ( 0 .. $jmax ) {
  16134.             $col += length( $$rfields[$j] );
  16135.  
  16136.             # create initial alignments for the new group
  16137.             my $token = "";
  16138.             if ( $j < $jmax ) { $token = $$rtokens[$j] }
  16139.             my $alignment = make_alignment( $col, $token );
  16140.             $new_line->set_alignment( $j, $alignment );
  16141.         }
  16142.  
  16143.         $maximum_jmax_seen = $jmax;
  16144.         $minimum_jmax_seen = $jmax;
  16145.     }
  16146.  
  16147.     # use previous alignments otherwise
  16148.     else {
  16149.         my @new_alignments =
  16150.           $group_lines[ $maximum_line_index - 1 ]->get_alignments();
  16151.         $new_line->set_alignments(@new_alignments);
  16152.     }
  16153. }
  16154.  
  16155. sub dump_array {
  16156.  
  16157.     # debug routine to dump array contents
  16158.     local $" = ')(';
  16159.     print "(@_)\n";
  16160. }
  16161.  
  16162. # flush() sends the current Perl::Tidy::VerticalAligner group down the
  16163. # pipeline to Perl::Tidy::FileWriter.
  16164.  
  16165. # This is the external flush, which also empties the cache
  16166. sub flush {
  16167.  
  16168.     if ( $maximum_line_index < 0 ) {
  16169.         if ($cached_line_type) {
  16170.             $file_writer_object->write_code_line( $cached_line_text . "\n" );
  16171.             $cached_line_type = 0;
  16172.             $cached_line_text = "";
  16173.         }
  16174.     }
  16175.     else {
  16176.         my_flush();
  16177.     }
  16178. }
  16179.  
  16180. # This is the internal flush, which leaves the cache intact
  16181. sub my_flush {
  16182.  
  16183.     return if ( $maximum_line_index < 0 );
  16184.  
  16185.     VALIGN_DEBUG_FLAG_APPEND0 && do {
  16186.         my $group_list_type = $group_lines[0]->get_list_type();
  16187.         my ( $a, $b, $c ) = caller();
  16188.         my $maximum_field_index = $group_lines[0]->get_jmax();
  16189.         print
  16190. "APPEND0: Flush called from $a $b $c fields=$maximum_field_index list=$group_list_type lines=$maximum_line_index extra=$extra_indent_ok\n";
  16191.  
  16192.     };
  16193.  
  16194.     # handle a group of comment lines
  16195.     if ( $group_type eq 'COMMENT' ) {
  16196.         my $leading_space_count = $comment_leading_space_count;
  16197.         my $leading_string      = get_leading_string($leading_space_count);
  16198.  
  16199.         # zero leading space count if any lines are too long
  16200.         my $max_excess = 0;
  16201.         for my $i ( 0 .. $maximum_line_index ) {
  16202.             my $str    = $group_lines[$i];
  16203.             my $excess =
  16204.               length($str) + $leading_space_count - $rOpts_maximum_line_length;
  16205.             if ( $excess > $max_excess ) {
  16206.                 $max_excess = $excess;
  16207.             }
  16208.         }
  16209.  
  16210.         if ( $max_excess > 0 ) {
  16211.             $leading_space_count -= $max_excess;
  16212.             if ( $leading_space_count < 0 ) { $leading_space_count = 0 }
  16213.             $last_outdented_line_at =
  16214.               $file_writer_object->get_output_line_number();
  16215.             unless ($outdented_line_count) {
  16216.                 $first_outdented_line_at = $last_outdented_line_at;
  16217.             }
  16218.             $outdented_line_count += ( $maximum_line_index + 1 );
  16219.         }
  16220.  
  16221.         # write the group of lines
  16222.         my $outdent_long_lines = 0;
  16223.         for my $i ( 0 .. $maximum_line_index ) {
  16224.             write_leader_and_string( $leading_space_count, $group_lines[$i], 0,
  16225.                 $outdent_long_lines, "" );
  16226.         }
  16227.     }
  16228.  
  16229.     # handle a group of code lines
  16230.     else {
  16231.  
  16232.         # some small groups are best left unaligned
  16233.         my $do_not_align = decide_if_aligned();
  16234.  
  16235.         # optimize side comment location
  16236.         $do_not_align = adjust_side_comment($do_not_align);
  16237.  
  16238.         # recover spaces for -lp option if possible
  16239.         my $extra_leading_spaces = get_extra_leading_spaces();
  16240.  
  16241.         # all lines of this group have the same basic leading spacing
  16242.         my $group_leader_length = $group_lines[0]->get_leading_space_count();
  16243.  
  16244.         # add extra leading spaces if helpful
  16245.         my $min_ci_gap =
  16246.           improve_continuation_indentation( $do_not_align,
  16247.             $group_leader_length );
  16248.  
  16249.         # loop to output all lines
  16250.         for my $i ( 0 .. $maximum_line_index ) {
  16251.             my $line = $group_lines[$i];
  16252.             write_vertically_aligned_line( $line, $min_ci_gap, $do_not_align,
  16253.                 $group_leader_length, $extra_leading_spaces );
  16254.         }
  16255.     }
  16256.     initialize_for_new_group();
  16257. }
  16258.  
  16259. sub decide_if_aligned {
  16260.  
  16261.     # Do not try to align two lines which are not really similar
  16262.     return unless $maximum_line_index == 1;
  16263.  
  16264.     my $group_list_type = $group_lines[0]->get_list_type();
  16265.  
  16266.     my $do_not_align = (
  16267.  
  16268.         # always align lists
  16269.         !$group_list_type
  16270.  
  16271.           && (
  16272.  
  16273.             # don't align if it was just a marginal match
  16274.             $marginal_match
  16275.  
  16276.             # don't align two lines with big gap
  16277.             || $group_maximum_gap > 12
  16278.  
  16279.             # or lines with differing number of alignment tokens
  16280.             || $previous_maximum_jmax_seen != $previous_minimum_jmax_seen
  16281.           )
  16282.     );
  16283.  
  16284.     # But try to convert them into a simple comment group if the first line
  16285.     # a has side comment
  16286.     my $rfields             = $group_lines[0]->get_rfields();
  16287.     my $maximum_field_index = $group_lines[0]->get_jmax();
  16288.     if (   $do_not_align
  16289.         && ( $maximum_line_index > 0 )
  16290.         && ( length( $$rfields[$maximum_field_index] ) > 0 ) )
  16291.     {
  16292.         combine_fields();
  16293.         $do_not_align = 0;
  16294.     }
  16295.     return $do_not_align;
  16296. }
  16297.  
  16298. sub adjust_side_comment {
  16299.  
  16300.     my $do_not_align = shift;
  16301.  
  16302.     # let's see if we can move the side comment field out a little
  16303.     # to improve readability (the last field is always a side comment field)
  16304.     my $have_side_comment       = 0;
  16305.     my $first_side_comment_line = -1;
  16306.     my $maximum_field_index     = $group_lines[0]->get_jmax();
  16307.     for my $i ( 0 .. $maximum_line_index ) {
  16308.         my $line = $group_lines[$i];
  16309.  
  16310.         if ( length( $line->get_rfields()->[$maximum_field_index] ) ) {
  16311.             $have_side_comment       = 1;
  16312.             $first_side_comment_line = $i;
  16313.             last;
  16314.         }
  16315.     }
  16316.  
  16317.     my $kmax = $maximum_field_index + 1;
  16318.  
  16319.     if ($have_side_comment) {
  16320.  
  16321.         my $line = $group_lines[0];
  16322.  
  16323.         # the maximum space without exceeding the line length:
  16324.         my $avail = $line->get_available_space_on_right();
  16325.  
  16326.         # try to use the previous comment column
  16327.         my $side_comment_column = $line->get_column( $kmax - 2 );
  16328.         my $move                = $last_comment_column - $side_comment_column;
  16329.  
  16330. ##        my $sc_line0 = $side_comment_history[0]->[0];
  16331. ##        my $sc_col0  = $side_comment_history[0]->[1];
  16332. ##        my $sc_line1 = $side_comment_history[1]->[0];
  16333. ##        my $sc_col1  = $side_comment_history[1]->[1];
  16334. ##        my $sc_line2 = $side_comment_history[2]->[0];
  16335. ##        my $sc_col2  = $side_comment_history[2]->[1];
  16336. ##
  16337. ##        # FUTURE UPDATES:
  16338. ##        # Be sure to ignore 'do not align' and  '} # end comments'
  16339. ##        # Find first $move > 0 and $move <= $avail as follows:
  16340. ##        # 1. try sc_col1 if sc_col1 == sc_col0 && (line-sc_line0) < 12
  16341. ##        # 2. try sc_col2 if (line-sc_line2) < 12
  16342. ##        # 3. try min possible space, plus up to 8,
  16343. ##        # 4. try min possible space
  16344.  
  16345.         if ( $kmax > 0 && !$do_not_align ) {
  16346.  
  16347.             # but if this doesn't work, give up and use the minimum space
  16348.             if ( $move > $avail ) {
  16349.                 $move = $rOpts_minimum_space_to_comment - 1;
  16350.             }
  16351.  
  16352.             # but we want some minimum space to the comment
  16353.             my $min_move = $rOpts_minimum_space_to_comment - 1;
  16354.             if (   $move >= 0
  16355.                 && $last_side_comment_length > 0
  16356.                 && ( $first_side_comment_line == 0 )
  16357.                 && $group_level == $last_group_level_written )
  16358.             {
  16359.                 $min_move = 0;
  16360.             }
  16361.  
  16362.             if ( $move < $min_move ) {
  16363.                 $move = $min_move;
  16364.             }
  16365.  
  16366.             # prevously, an upper bound was placed on $move here,
  16367.             # (maximum_space_to_comment), but it was not helpful
  16368.  
  16369.             # don't exceed the available space
  16370.             if ( $move > $avail ) { $move = $avail }
  16371.  
  16372.             # we can only increase space, never decrease
  16373.             if ( $move > 0 ) {
  16374.                 $line->increase_field_width( $maximum_field_index - 1, $move );
  16375.             }
  16376.  
  16377.             # remember this column for the next group
  16378.             $last_comment_column = $line->get_column( $kmax - 2 );
  16379.         }
  16380.         else {
  16381.  
  16382.             # try to at least line up the existing side comment location
  16383.             if ( $kmax > 0 && $move > 0 && $move < $avail ) {
  16384.                 $line->increase_field_width( $maximum_field_index - 1, $move );
  16385.                 $do_not_align = 0;
  16386.             }
  16387.  
  16388.             # reset side comment column if we can't align
  16389.             else {
  16390.                 forget_side_comment();
  16391.             }
  16392.         }
  16393.     }
  16394.     return $do_not_align;
  16395. }
  16396.  
  16397. sub improve_continuation_indentation {
  16398.     my ( $do_not_align, $group_leader_length ) = @_;
  16399.  
  16400.     # See if we can increase the continuation indentation
  16401.     # to move all continuation lines closer to the next field
  16402.     # (unless it is a comment).
  16403.     #
  16404.     # '$min_ci_gap'is the extra indentation that we may need to introduce.
  16405.     # We will only introduce this to fields which already have some ci.
  16406.     # Without this variable, we would occasionally get something like this
  16407.     # (Complex.pm):
  16408.     #
  16409.     # use overload '+' => \&plus,
  16410.     #   '-'            => \&minus,
  16411.     #   '*'            => \&multiply,
  16412.     #   ...
  16413.     #   'tan'          => \&tan,
  16414.     #   'atan2'        => \&atan2,
  16415.     #
  16416.     # Whereas with this variable, we can shift variables over to get this:
  16417.     #
  16418.     # use overload '+' => \&plus,
  16419.     #          '-'     => \&minus,
  16420.     #          '*'     => \&multiply,
  16421.     #          ...
  16422.     #          'tan'   => \&tan,
  16423.     #          'atan2' => \&atan2,
  16424.  
  16425.     ## BUBBA: Deactivated####################
  16426.     # The trouble with this patch is that it may, for example,
  16427.     # move in some 'or's  or ':'s, and leave some out, so that the
  16428.     # left edge alignment suffers.
  16429.     return 0;
  16430.     ###########################################
  16431.  
  16432.     my $maximum_field_index = $group_lines[0]->get_jmax();
  16433.  
  16434.     my $min_ci_gap = $rOpts_maximum_line_length;
  16435.     if ( $maximum_field_index > 1 && !$do_not_align ) {
  16436.  
  16437.         for my $i ( 0 .. $maximum_line_index ) {
  16438.             my $line                = $group_lines[$i];
  16439.             my $leading_space_count = $line->get_leading_space_count();
  16440.             my $rfields             = $line->get_rfields();
  16441.  
  16442.             my $gap = $line->get_column(0) - $leading_space_count -
  16443.               length( $$rfields[0] );
  16444.  
  16445.             if ( $leading_space_count > $group_leader_length ) {
  16446.                 if ( $gap < $min_ci_gap ) { $min_ci_gap = $gap }
  16447.             }
  16448.         }
  16449.  
  16450.         if ( $min_ci_gap >= $rOpts_maximum_line_length ) {
  16451.             $min_ci_gap = 0;
  16452.         }
  16453.     }
  16454.     else {
  16455.         $min_ci_gap = 0;
  16456.     }
  16457.     return $min_ci_gap;
  16458. }
  16459.  
  16460. sub write_vertically_aligned_line {
  16461.  
  16462.     my ( $line, $min_ci_gap, $do_not_align, $group_leader_length,
  16463.         $extra_leading_spaces )
  16464.       = @_;
  16465.     my $rfields                   = $line->get_rfields();
  16466.     my $leading_space_count       = $line->get_leading_space_count();
  16467.     my $outdent_long_lines        = $line->get_outdent_long_lines();
  16468.     my $maximum_field_index       = $line->get_jmax();
  16469.     my $rvertical_tightness_flags = $line->get_rvertical_tightness_flags();
  16470.  
  16471.     # add any extra spaces
  16472.     if ( $leading_space_count > $group_leader_length ) {
  16473.         $leading_space_count += $min_ci_gap;
  16474.     }
  16475.  
  16476.     my $str = $$rfields[0];
  16477.  
  16478.     # loop to concatenate all fields of this line and needed padding
  16479.     my $total_pad_count = 0;
  16480.     my ( $j, $pad );
  16481.     for $j ( 1 .. $maximum_field_index ) {
  16482.  
  16483.         # skip zero-length side comments
  16484.         last
  16485.           if ( ( $j == $maximum_field_index )
  16486.             && ( !defined( $$rfields[$j] ) || ( length( $$rfields[$j] ) == 0 ) )
  16487.           );
  16488.  
  16489.         # compute spaces of padding before this field
  16490.         my $col = $line->get_column( $j - 1 );
  16491.         $pad = $col - ( length($str) + $leading_space_count );
  16492.  
  16493.         if ($do_not_align) {
  16494.             $pad =
  16495.               ( $j < $maximum_field_index )
  16496.               ? 0
  16497.               : $rOpts_minimum_space_to_comment - 1;
  16498.         }
  16499.  
  16500.         # accumulate the padding
  16501.         if ( $pad > 0 ) { $total_pad_count += $pad; }
  16502.  
  16503.         # add this field
  16504.         if ( !defined $$rfields[$j] ) {
  16505.             write_diagnostics("UNDEFined field at j=$j\n");
  16506.         }
  16507.  
  16508.         # only add padding when we have a finite field;
  16509.         # this avoids extra terminal spaces if we have empty fields
  16510.         if ( length( $$rfields[$j] ) > 0 ) {
  16511.             $str .= ' ' x $total_pad_count;
  16512.             $total_pad_count = 0;
  16513.             $str .= $$rfields[$j];
  16514.         }
  16515.  
  16516.         # update side comment history buffer
  16517.         if ( $j == $maximum_field_index ) {
  16518.             my $lineno = $file_writer_object->get_output_line_number();
  16519.             shift @side_comment_history;
  16520.             push @side_comment_history, [ $lineno, $col ];
  16521.         }
  16522.     }
  16523.  
  16524.     my $side_comment_length = ( length( $$rfields[$maximum_field_index] ) );
  16525.  
  16526.     # ship this line off
  16527.     write_leader_and_string( $leading_space_count + $extra_leading_spaces,
  16528.         $str, $side_comment_length, $outdent_long_lines,
  16529.         $rvertical_tightness_flags );
  16530. }
  16531.  
  16532. sub get_extra_leading_spaces {
  16533.  
  16534.     #----------------------------------------------------------
  16535.     # Define any extra indentation space (for the -lp option).
  16536.     # Here is why:
  16537.     # If a list has side comments, sub scan_list must dump the
  16538.     # list before it sees everything.  When this happens, it sets
  16539.     # the indentation to the standard scheme, but notes how
  16540.     # many spaces it would have liked to use.  We may be able
  16541.     # to recover that space here in the event that that all of the
  16542.     # lines of a list are back together again.
  16543.     #----------------------------------------------------------
  16544.  
  16545.     my $extra_leading_spaces = 0;
  16546.     if ($extra_indent_ok) {
  16547.         my $object = $group_lines[0]->get_indentation();
  16548.         if ( ref($object) ) {
  16549.             my $extra_indentation_spaces_wanted =
  16550.               get_RECOVERABLE_SPACES($object);
  16551.  
  16552.             # all indentation objects must be the same
  16553.             my $i;
  16554.             for $i ( 1 .. $maximum_line_index ) {
  16555.                 if ( $object != $group_lines[$i]->get_indentation() ) {
  16556.                     $extra_indentation_spaces_wanted = 0;
  16557.                     last;
  16558.                 }
  16559.             }
  16560.  
  16561.             if ($extra_indentation_spaces_wanted) {
  16562.  
  16563.                 # the maximum space without exceeding the line length:
  16564.                 my $avail = $group_lines[0]->get_available_space_on_right();
  16565.                 $extra_leading_spaces =
  16566.                   ( $avail > $extra_indentation_spaces_wanted )
  16567.                   ? $extra_indentation_spaces_wanted
  16568.                   : $avail;
  16569.  
  16570.                 # update the indentation object because with -icp the terminal
  16571.                 # ');' will use the same adjustment.
  16572.                 $object->permanently_decrease_AVAILABLE_SPACES(
  16573.                     -$extra_leading_spaces );
  16574.             }
  16575.         }
  16576.     }
  16577.     return $extra_leading_spaces;
  16578. }
  16579.  
  16580. sub combine_fields {
  16581.  
  16582.     # combine all fields except for the comment field  ( sidecmt.t )
  16583.     my ( $j, $k );
  16584.     my $maximum_field_index = $group_lines[0]->get_jmax();
  16585.     for ( $j = 0 ; $j <= $maximum_line_index ; $j++ ) {
  16586.         my $line    = $group_lines[$j];
  16587.         my $rfields = $line->get_rfields();
  16588.         foreach ( 1 .. $maximum_field_index - 1 ) {
  16589.             $$rfields[0] .= $$rfields[$_];
  16590.         }
  16591.         $$rfields[1] = $$rfields[$maximum_field_index];
  16592.  
  16593.         $line->set_jmax(1);
  16594.         $line->set_column( 0, 0 );
  16595.         $line->set_column( 1, 0 );
  16596.  
  16597.     }
  16598.     $maximum_field_index = 1;
  16599.  
  16600.     for $j ( 0 .. $maximum_line_index ) {
  16601.         my $line    = $group_lines[$j];
  16602.         my $rfields = $line->get_rfields();
  16603.         for $k ( 0 .. $maximum_field_index ) {
  16604.             my $pad = length( $$rfields[$k] ) - $line->current_field_width($k);
  16605.             if ( $k == 0 ) {
  16606.                 $pad += $group_lines[$j]->get_leading_space_count();
  16607.             }
  16608.  
  16609.             if ( $pad > 0 ) { $line->increase_field_width( $k, $pad ) }
  16610.  
  16611.         }
  16612.     }
  16613. }
  16614.  
  16615. sub get_output_line_number {
  16616.  
  16617.     # the output line number reported to a caller is the number of items
  16618.     # written plus the number of items in the buffer
  16619.     my $self = shift;
  16620.     1 + $maximum_line_index + $file_writer_object->get_output_line_number();
  16621. }
  16622.  
  16623. sub write_leader_and_string {
  16624.  
  16625.     my ( $leading_space_count, $str, $side_comment_length, $outdent_long_lines,
  16626.         $rvertical_tightness_flags )
  16627.       = @_;
  16628.  
  16629.     my $leading_string = get_leading_string($leading_space_count);
  16630.  
  16631.     # handle outdenting of long lines:
  16632.     if ($outdent_long_lines) {
  16633.         my $excess =
  16634.           length($str) - $side_comment_length + $leading_space_count -
  16635.           $rOpts_maximum_line_length;
  16636.         if ( $excess > 0 ) {
  16637.             $leading_string         = "";
  16638.             $last_outdented_line_at =
  16639.               $file_writer_object->get_output_line_number();
  16640.  
  16641.             unless ($outdented_line_count) {
  16642.                 $first_outdented_line_at = $last_outdented_line_at;
  16643.             }
  16644.             $outdented_line_count++;
  16645.         }
  16646.     }
  16647.  
  16648.     # Unpack any recombination data; it was packed by
  16649.     # sub send_lines_to_vertical_aligner. Contents:
  16650.     #
  16651.     #   [0] type: 1=opening  2=closing  3=opening block brace
  16652.     #   [1] flag: if opening: 1=no multiple steps, 2=multiple steps ok
  16653.     #             if closing: spaces of padding to use
  16654.     #   [2] sequence number of container
  16655.     #   [3] valid flag: do not append if this flag is false
  16656.     #
  16657.     my ( $open_or_close, $tightness_flag, $seqno, $valid );
  16658.     if ($rvertical_tightness_flags) {
  16659.         ( $open_or_close, $tightness_flag, $seqno, $valid ) =
  16660.           @{$rvertical_tightness_flags};
  16661.     }
  16662.  
  16663.     # handle any cached line ..
  16664.     # either append this line to it or write it out
  16665.     if ($cached_line_text) {
  16666.  
  16667.         if ( !$cached_line_valid ) {
  16668.             $file_writer_object->write_code_line( $cached_line_text . "\n" );
  16669.         }
  16670.  
  16671.         # handle cached line with opening container token
  16672.         elsif ( $cached_line_type == 1 || $cached_line_type == 3 ) {
  16673.  
  16674.             my $gap = $leading_space_count - length($cached_line_text);
  16675.  
  16676.             # handle option of just one tight opening per line:
  16677.             if ( $cached_line_flag == 1 ) {
  16678.                 if ( defined($open_or_close) && $open_or_close == 1 ) {
  16679.                     $gap = -1;
  16680.                 }
  16681.             }
  16682.  
  16683.             if ( $gap >= 0 ) {
  16684.                 $leading_string = $cached_line_text . ' ' x $gap;
  16685.             }
  16686.             else {
  16687.                 $file_writer_object->write_code_line(
  16688.                     $cached_line_text . "\n" );
  16689.             }
  16690.         }
  16691.  
  16692.         # handle cached line to place before this closing container token
  16693.         else {
  16694.             my $test_line = $cached_line_text . ' ' x $cached_line_flag . $str;
  16695.  
  16696.             if ( length($test_line) <= $rOpts_maximum_line_length ) {
  16697.                 $str            = $test_line;
  16698.                 $leading_string = "";
  16699.             }
  16700.             else {
  16701.                 $file_writer_object->write_code_line(
  16702.                     $cached_line_text . "\n" );
  16703.             }
  16704.         }
  16705.     }
  16706.     $cached_line_type = 0;
  16707.     $cached_line_text = "";
  16708.  
  16709.     my $line = $leading_string . $str;
  16710.  
  16711.     # write or cache this line
  16712.     if ( !$rvertical_tightness_flags || $side_comment_length > 0 ) {
  16713.         $file_writer_object->write_code_line( $line . "\n" );
  16714.     }
  16715.     else {
  16716.         $cached_line_text  = $line;
  16717.         $cached_line_type  = $open_or_close;
  16718.         $cached_line_flag  = $tightness_flag;
  16719.         $cached_seqno      = $seqno;
  16720.         $cached_line_valid = $valid;
  16721.     }
  16722.  
  16723.     $last_group_level_written = $group_level;
  16724.     $last_side_comment_length = $side_comment_length;
  16725.     $extra_indent_ok          = 0;
  16726. }
  16727.  
  16728. {    # begin get_leading_string
  16729.  
  16730.     my @leading_string_cache;
  16731.  
  16732.     sub get_leading_string {
  16733.  
  16734.         # define the leading whitespace string for this line..
  16735.         my $leading_whitespace_count = shift;
  16736.  
  16737.         # Handle case of zero whitespace, which includes multi-line quotes
  16738.         # (which may have a finite level; this prevents tab problems)
  16739.         if ( $leading_whitespace_count <= 0 ) {
  16740.             return "";
  16741.         }
  16742.  
  16743.         # look for previous result
  16744.         elsif ( $leading_string_cache[$leading_whitespace_count] ) {
  16745.             return $leading_string_cache[$leading_whitespace_count];
  16746.         }
  16747.  
  16748.         # must compute a string for this number of spaces
  16749.         my $leading_string;
  16750.  
  16751.         # Handle simple case of no tabs
  16752.         if ( !( $rOpts_tabs || $rOpts_entab_leading_whitespace )
  16753.             || $rOpts_indent_columns <= 0 )
  16754.         {
  16755.             $leading_string = ( ' ' x $leading_whitespace_count );
  16756.         }
  16757.  
  16758.         # Handle entab option
  16759.         elsif ($rOpts_entab_leading_whitespace) {
  16760.             my $space_count =
  16761.               $leading_whitespace_count % $rOpts_entab_leading_whitespace;
  16762.             my $tab_count =
  16763.               int(
  16764.                 $leading_whitespace_count / $rOpts_entab_leading_whitespace );
  16765.             $leading_string = "\t" x $tab_count . ' ' x $space_count;
  16766.         }
  16767.  
  16768.         # Handle option of one tab per level
  16769.         else {
  16770.             $leading_string = ( "\t" x $group_level );
  16771.             my $space_count =
  16772.               $leading_whitespace_count - $group_level * $rOpts_indent_columns;
  16773.  
  16774.             # shouldn't happen:
  16775.             if ( $space_count < 0 ) {
  16776.                 warning(
  16777. "Error in append_line: for level=$group_level count=$leading_whitespace_count\n"
  16778.                 );
  16779.                 $leading_string = ( ' ' x $leading_whitespace_count );
  16780.             }
  16781.             else {
  16782.                 $leading_string .= ( ' ' x $space_count );
  16783.             }
  16784.         }
  16785.         $leading_string_cache[$leading_whitespace_count] = $leading_string;
  16786.         return $leading_string;
  16787.     }
  16788. }    # end get_leading_string
  16789.  
  16790. sub report_anything_unusual {
  16791.     my $self = shift;
  16792.     if ( $outdented_line_count > 0 ) {
  16793.         write_logfile_entry(
  16794.             "$outdented_line_count long lines were outdented:\n");
  16795.         write_logfile_entry(
  16796.             "  First at output line $first_outdented_line_at\n");
  16797.  
  16798.         if ( $outdented_line_count > 1 ) {
  16799.             write_logfile_entry(
  16800.                 "   Last at output line $last_outdented_line_at\n");
  16801.         }
  16802.         write_logfile_entry(
  16803.             "  use -noll to prevent outdenting, -l=n to increase line length\n"
  16804.         );
  16805.         write_logfile_entry("\n");
  16806.     }
  16807. }
  16808.  
  16809. #####################################################################
  16810. #
  16811. # the Perl::Tidy::FileWriter class writes the output file
  16812. #
  16813. #####################################################################
  16814.  
  16815. package Perl::Tidy::FileWriter;
  16816.  
  16817. # Maximum number of little messages; probably need not be changed.
  16818. use constant MAX_NAG_MESSAGES => 6;
  16819.  
  16820. sub write_logfile_entry {
  16821.     my $self          = shift;
  16822.     my $logger_object = $self->{_logger_object};
  16823.     if ($logger_object) {
  16824.         $logger_object->write_logfile_entry(@_);
  16825.     }
  16826. }
  16827.  
  16828. sub new {
  16829.     my $class = shift;
  16830.     my ( $line_sink_object, $rOpts, $logger_object ) = @_;
  16831.  
  16832.     bless {
  16833.         _line_sink_object           => $line_sink_object,
  16834.         _logger_object              => $logger_object,
  16835.         _rOpts                      => $rOpts,
  16836.         _output_line_number         => 1,
  16837.         _consecutive_blank_lines    => 0,
  16838.         _consecutive_nonblank_lines => 0,
  16839.         _first_line_length_error    => 0,
  16840.         _max_line_length_error      => 0,
  16841.         _last_line_length_error     => 0,
  16842.         _first_line_length_error_at => 0,
  16843.         _max_line_length_error_at   => 0,
  16844.         _last_line_length_error_at  => 0,
  16845.         _line_length_error_count    => 0,
  16846.         _max_output_line_length     => 0,
  16847.         _max_output_line_length_at  => 0,
  16848.     }, $class;
  16849. }
  16850.  
  16851. sub tee_on {
  16852.     my $self = shift;
  16853.     $self->{_line_sink_object}->tee_on();
  16854. }
  16855.  
  16856. sub tee_off {
  16857.     my $self = shift;
  16858.     $self->{_line_sink_object}->tee_off();
  16859. }
  16860.  
  16861. sub get_output_line_number {
  16862.     my $self = shift;
  16863.     return $self->{_output_line_number};
  16864. }
  16865.  
  16866. sub decrement_output_line_number {
  16867.     my $self = shift;
  16868.     $self->{_output_line_number}--;
  16869. }
  16870.  
  16871. sub get_consecutive_nonblank_lines {
  16872.     my $self = shift;
  16873.     return $self->{_consecutive_nonblank_lines};
  16874. }
  16875.  
  16876. sub reset_consecutive_blank_lines {
  16877.     my $self = shift;
  16878.     $self->{_consecutive_blank_lines} = 0;
  16879. }
  16880.  
  16881. sub want_blank_line {
  16882.     my $self = shift;
  16883.     unless ( $self->{_consecutive_blank_lines} ) {
  16884.         $self->write_blank_code_line();
  16885.     }
  16886. }
  16887.  
  16888. sub write_blank_code_line {
  16889.     my $self  = shift;
  16890.     my $rOpts = $self->{_rOpts};
  16891.     return
  16892.       if ( $self->{_consecutive_blank_lines} >=
  16893.         $rOpts->{'maximum-consecutive-blank-lines'} );
  16894.     $self->{_consecutive_blank_lines}++;
  16895.     $self->{_consecutive_nonblank_lines} = 0;
  16896.     $self->write_line("\n");
  16897. }
  16898.  
  16899. sub write_code_line {
  16900.     my $self = shift;
  16901.     my $a    = shift;
  16902.  
  16903.     if ( $a =~ /^\s*$/ ) {
  16904.         my $rOpts = $self->{_rOpts};
  16905.         return
  16906.           if ( $self->{_consecutive_blank_lines} >=
  16907.             $rOpts->{'maximum-consecutive-blank-lines'} );
  16908.         $self->{_consecutive_blank_lines}++;
  16909.         $self->{_consecutive_nonblank_lines} = 0;
  16910.     }
  16911.     else {
  16912.         $self->{_consecutive_blank_lines} = 0;
  16913.         $self->{_consecutive_nonblank_lines}++;
  16914.     }
  16915.     $self->write_line($a);
  16916. }
  16917.  
  16918. sub write_line {
  16919.     my $self = shift;
  16920.     my $a    = shift;
  16921.     $self->{_line_sink_object}->write_line($a);
  16922.     if ( $a =~ /\n$/ ) { $self->{_output_line_number}++; }
  16923.  
  16924.     # This calculation of excess line length ignores any internal tabs
  16925.     my $rOpts  = $self->{_rOpts};
  16926.     my $exceed = length($a) - $rOpts->{'maximum-line-length'} - 1;
  16927.     if ( $a =~ /^\t+/g ) {
  16928.         $exceed += pos($a) * ( $rOpts->{'indent-columns'} - 1 );
  16929.     }
  16930.  
  16931.     # Note that we just incremented output line number to future value
  16932.     # so we must subtract 1 for current line number
  16933.     if ( length($a) > 1 + $self->{_max_output_line_length} ) {
  16934.         $self->{_max_output_line_length}    = length($a) - 1;
  16935.         $self->{_max_output_line_length_at} = $self->{_output_line_number} - 1;
  16936.     }
  16937.  
  16938.     if ( $exceed > 0 ) {
  16939.         my $output_line_number = $self->{_output_line_number};
  16940.         $self->{_last_line_length_error}    = $exceed;
  16941.         $self->{_last_line_length_error_at} = $output_line_number - 1;
  16942.         if ( $self->{_line_length_error_count} == 0 ) {
  16943.             $self->{_first_line_length_error}    = $exceed;
  16944.             $self->{_first_line_length_error_at} = $output_line_number - 1;
  16945.         }
  16946.  
  16947.         if (
  16948.             $self->{_last_line_length_error} > $self->{_max_line_length_error} )
  16949.         {
  16950.             $self->{_max_line_length_error}    = $exceed;
  16951.             $self->{_max_line_length_error_at} = $output_line_number - 1;
  16952.         }
  16953.  
  16954.         if ( $self->{_line_length_error_count} < MAX_NAG_MESSAGES ) {
  16955.             $self->write_logfile_entry(
  16956.                 "Line length exceeded by $exceed characters\n");
  16957.         }
  16958.         $self->{_line_length_error_count}++;
  16959.     }
  16960.  
  16961. }
  16962.  
  16963. sub report_line_length_errors {
  16964.     my $self                    = shift;
  16965.     my $rOpts                   = $self->{_rOpts};
  16966.     my $line_length_error_count = $self->{_line_length_error_count};
  16967.     if ( $line_length_error_count == 0 ) {
  16968.         $self->write_logfile_entry(
  16969.             "No lines exceeded $rOpts->{'maximum-line-length'} characters\n");
  16970.         my $max_output_line_length    = $self->{_max_output_line_length};
  16971.         my $max_output_line_length_at = $self->{_max_output_line_length_at};
  16972.         $self->write_logfile_entry(
  16973. "  Maximum output line length was $max_output_line_length at line $max_output_line_length_at\n"
  16974.         );
  16975.  
  16976.     }
  16977.     else {
  16978.  
  16979.         my $word = ( $line_length_error_count > 1 ) ? "s" : "";
  16980.         $self->write_logfile_entry(
  16981. "$line_length_error_count output line$word exceeded $rOpts->{'maximum-line-length'} characters:\n"
  16982.         );
  16983.  
  16984.         $word = ( $line_length_error_count > 1 ) ? "First" : "";
  16985.         my $first_line_length_error    = $self->{_first_line_length_error};
  16986.         my $first_line_length_error_at = $self->{_first_line_length_error_at};
  16987.         $self->write_logfile_entry(
  16988. " $word at line $first_line_length_error_at by $first_line_length_error characters\n"
  16989.         );
  16990.  
  16991.         if ( $line_length_error_count > 1 ) {
  16992.             my $max_line_length_error     = $self->{_max_line_length_error};
  16993.             my $max_line_length_error_at  = $self->{_max_line_length_error_at};
  16994.             my $last_line_length_error    = $self->{_last_line_length_error};
  16995.             my $last_line_length_error_at = $self->{_last_line_length_error_at};
  16996.             $self->write_logfile_entry(
  16997. " Maximum at line $max_line_length_error_at by $max_line_length_error characters\n"
  16998.             );
  16999.             $self->write_logfile_entry(
  17000. " Last at line $last_line_length_error_at by $last_line_length_error characters\n"
  17001.             );
  17002.         }
  17003.     }
  17004. }
  17005.  
  17006. #####################################################################
  17007. #
  17008. # The Perl::Tidy::Debugger class shows line tokenization
  17009. #
  17010. #####################################################################
  17011.  
  17012. package Perl::Tidy::Debugger;
  17013.  
  17014. sub new {
  17015.  
  17016.     my ( $class, $filename ) = @_;
  17017.  
  17018.     bless {
  17019.         _debug_file        => $filename,
  17020.         _debug_file_opened => 0,
  17021.         _fh                => undef,
  17022.     }, $class;
  17023. }
  17024.  
  17025. sub really_open_debug_file {
  17026.  
  17027.     my $self       = shift;
  17028.     my $debug_file = $self->{_debug_file};
  17029.     my $fh;
  17030.     unless ( $fh = IO::File->new("> $debug_file") ) {
  17031.         warn("can't open $debug_file: $!\n");
  17032.     }
  17033.     $self->{_debug_file_opened} = 1;
  17034.     $self->{_fh}                = $fh;
  17035.     print $fh
  17036.       "Use -dump-token-types (-dtt) to get a list of token type codes\n";
  17037. }
  17038.  
  17039. sub close_debug_file {
  17040.  
  17041.     my $self = shift;
  17042.     my $fh   = $self->{_fh};
  17043.     if ( $self->{_debug_file_opened} ) {
  17044.  
  17045.         eval { $self->{_fh}->close() };
  17046.     }
  17047. }
  17048.  
  17049. sub write_debug_entry {
  17050.  
  17051.     # This is a debug dump routine which may be modified as necessary
  17052.     # to dump tokens on a line-by-line basis.  The output will be written
  17053.     # to the .DEBUG file when the -D flag is entered.
  17054.     my $self           = shift;
  17055.     my $line_of_tokens = shift;
  17056.  
  17057.     my $input_line        = $line_of_tokens->{_line_text};
  17058.     my $rtoken_type       = $line_of_tokens->{_rtoken_type};
  17059.     my $rtokens           = $line_of_tokens->{_rtokens};
  17060.     my $rlevels           = $line_of_tokens->{_rlevels};
  17061.     my $rslevels          = $line_of_tokens->{_rslevels};
  17062.     my $rblock_type       = $line_of_tokens->{_rblock_type};
  17063.     my $input_line_number = $line_of_tokens->{_line_number};
  17064.     my $line_type         = $line_of_tokens->{_line_type};
  17065.  
  17066.     my ( $j, $num );
  17067.  
  17068.     my $token_str              = "$input_line_number: ";
  17069.     my $reconstructed_original = "$input_line_number: ";
  17070.     my $block_str              = "$input_line_number: ";
  17071.  
  17072.     #$token_str .= "$line_type: ";
  17073.     #$reconstructed_original .= "$line_type: ";
  17074.  
  17075.     my $pattern   = "";
  17076.     my @next_char = ( '"', '"' );
  17077.     my $i_next    = 0;
  17078.     unless ( $self->{_debug_file_opened} ) { $self->really_open_debug_file() }
  17079.     my $fh = $self->{_fh};
  17080.  
  17081.     for ( $j = 0 ; $j < @$rtoken_type ; $j++ ) {
  17082.  
  17083.         # testing patterns
  17084.         if ( $$rtoken_type[$j] eq 'k' ) {
  17085.             $pattern .= $$rtokens[$j];
  17086.         }
  17087.         else {
  17088.             $pattern .= $$rtoken_type[$j];
  17089.         }
  17090.         $reconstructed_original .= $$rtokens[$j];
  17091.         $block_str .= "($$rblock_type[$j])";
  17092.         $num = length( $$rtokens[$j] );
  17093.         my $type_str = $$rtoken_type[$j];
  17094.  
  17095.         # be sure there are no blank tokens (shouldn't happen)
  17096.         # This can only happen if a programming error has been made
  17097.         # because all valid tokens are non-blank
  17098.         if ( $type_str eq ' ' ) {
  17099.             print $fh "BLANK TOKEN on the next line\n";
  17100.             $type_str = $next_char[$i_next];
  17101.             $i_next   = 1 - $i_next;
  17102.         }
  17103.  
  17104.         if ( length($type_str) == 1 ) {
  17105.             $type_str = $type_str x $num;
  17106.         }
  17107.         $token_str .= $type_str;
  17108.     }
  17109.  
  17110.     # Write what you want here ...
  17111.     # print $fh "$input_line\n";
  17112.     # print $fh "$pattern\n";
  17113.     print $fh "$reconstructed_original\n";
  17114.     print $fh "$token_str\n";
  17115.  
  17116.     #print $fh "$block_str\n";
  17117. }
  17118.  
  17119. #####################################################################
  17120. #
  17121. # The Perl::Tidy::LineBuffer class supplies a 'get_line()'
  17122. # method for returning the next line to be parsed, as well as a
  17123. # 'peek_ahead()' method
  17124. #
  17125. # The input parameter is an object with a 'get_line()' method
  17126. # which returns the next line to be parsed
  17127. #
  17128. #####################################################################
  17129.  
  17130. package Perl::Tidy::LineBuffer;
  17131.  
  17132. sub new {
  17133.  
  17134.     my $class              = shift;
  17135.     my $line_source_object = shift;
  17136.  
  17137.     return bless {
  17138.         _line_source_object => $line_source_object,
  17139.         _rlookahead_buffer  => [],
  17140.     }, $class;
  17141. }
  17142.  
  17143. sub peek_ahead {
  17144.     my $self               = shift;
  17145.     my $buffer_index       = shift;
  17146.     my $line               = undef;
  17147.     my $line_source_object = $self->{_line_source_object};
  17148.     my $rlookahead_buffer  = $self->{_rlookahead_buffer};
  17149.     if ( $buffer_index < scalar(@$rlookahead_buffer) ) {
  17150.         $line = $$rlookahead_buffer[$buffer_index];
  17151.     }
  17152.     else {
  17153.         $line = $line_source_object->get_line();
  17154.         push ( @$rlookahead_buffer, $line );
  17155.     }
  17156.     return $line;
  17157. }
  17158.  
  17159. sub get_line {
  17160.     my $self               = shift;
  17161.     my $line               = undef;
  17162.     my $line_source_object = $self->{_line_source_object};
  17163.     my $rlookahead_buffer  = $self->{_rlookahead_buffer};
  17164.  
  17165.     if ( scalar(@$rlookahead_buffer) ) {
  17166.         $line = shift @$rlookahead_buffer;
  17167.     }
  17168.     else {
  17169.         $line = $line_source_object->get_line();
  17170.     }
  17171.     return $line;
  17172. }
  17173.  
  17174. ########################################################################
  17175. #
  17176. # the Perl::Tidy::Tokenizer package is essentially a filter which
  17177. # reads lines of perl source code from a source object and provides
  17178. # corresponding tokenized lines through its get_line() method.  Lines
  17179. # flow from the source_object to the caller like this:
  17180. #
  17181. # source_object --> LineBuffer_object --> Tokenizer -->  calling routine
  17182. #   get_line()         get_line()           get_line()     line_of_tokens
  17183. #
  17184. # The source object can be any object with a get_line() method which
  17185. # supplies one line (a character string) perl call.
  17186. # The LineBuffer object is created by the Tokenizer.
  17187. # The Tokenizer returns a reference to a data structure 'line_of_tokens'
  17188. # containing one tokenized line for each call to its get_line() method.
  17189. #
  17190. # WARNING: This is not a real class yet.  Only one tokenizer my be used.
  17191. #
  17192. ########################################################################
  17193.  
  17194. package Perl::Tidy::Tokenizer;
  17195.  
  17196. BEGIN {
  17197.  
  17198.     # Caution: these debug flags produce a lot of output
  17199.     # They should all be 0 except when debugging small scripts
  17200.  
  17201.     use constant TOKENIZER_DEBUG_FLAG_EXPECT   => 0;
  17202.     use constant TOKENIZER_DEBUG_FLAG_NSCAN    => 0;
  17203.     use constant TOKENIZER_DEBUG_FLAG_QUOTE    => 0;
  17204.     use constant TOKENIZER_DEBUG_FLAG_SCAN_ID  => 0;
  17205.     use constant TOKENIZER_DEBUG_FLAG_TOKENIZE => 0;
  17206.  
  17207.     my $debug_warning = sub {
  17208.         print "TOKENIZER_DEBUGGING with key $_[0]\n";
  17209.     };
  17210.  
  17211.     TOKENIZER_DEBUG_FLAG_EXPECT   && $debug_warning->('EXPECT');
  17212.     TOKENIZER_DEBUG_FLAG_NSCAN    && $debug_warning->('NSCAN');
  17213.     TOKENIZER_DEBUG_FLAG_QUOTE    && $debug_warning->('QUOTE');
  17214.     TOKENIZER_DEBUG_FLAG_SCAN_ID  && $debug_warning->('SCAN_ID');
  17215.     TOKENIZER_DEBUG_FLAG_TOKENIZE && $debug_warning->('TOKENIZE');
  17216.  
  17217. }
  17218.  
  17219. use Carp;
  17220. use vars qw{
  17221.   $tokenizer_self
  17222.   $level_in_tokenizer
  17223.   $slevel_in_tokenizer
  17224.   $nesting_token_string
  17225.   $nesting_type_string
  17226.   $nesting_block_string
  17227.   $nesting_block_flag
  17228.   $nesting_list_string
  17229.   $nesting_list_flag
  17230.   $saw_negative_indentation
  17231.   $id_scan_state
  17232.   $last_nonblank_token
  17233.   $last_nonblank_type
  17234.   $last_nonblank_block_type
  17235.   $last_nonblank_container_type
  17236.   $last_nonblank_type_sequence
  17237.   $last_last_nonblank_token
  17238.   $last_last_nonblank_type
  17239.   $last_last_nonblank_block_type
  17240.   $last_last_nonblank_container_type
  17241.   $last_last_nonblank_type_sequence
  17242.   $last_nonblank_prototype
  17243.   $statement_type
  17244.   $identifier
  17245.   $in_quote
  17246.   $quote_type
  17247.   $quote_character
  17248.   $quote_pos
  17249.   $quote_depth
  17250.   $allowed_quote_modifiers
  17251.   $paren_depth
  17252.   @paren_type
  17253.   @paren_semicolon_count
  17254.   @paren_structural_type
  17255.   $brace_depth
  17256.   @brace_type
  17257.   @brace_structural_type
  17258.   @brace_statement_type
  17259.   @brace_context
  17260.   @brace_package
  17261.   $square_bracket_depth
  17262.   @square_bracket_type
  17263.   @square_bracket_structural_type
  17264.   @depth_array
  17265.   @starting_line_of_current_depth
  17266.   @current_depth
  17267.   @current_sequence_number
  17268.   @nesting_sequence_number
  17269.   @lower_case_labels_at
  17270.   $saw_v_string
  17271.   %is_constant
  17272.   %is_user_function
  17273.   %user_function_prototype
  17274.   %saw_function_definition
  17275.   $max_token_index
  17276.   $peeked_ahead
  17277.   $current_package
  17278.   $unexpected_error_count
  17279.   $input_line
  17280.   $input_line_number
  17281.   $rpretokens
  17282.   $rpretoken_map
  17283.   $rpretoken_type
  17284.   $want_paren
  17285.   $context
  17286.   @slevel_stack
  17287.   $ci_string_in_tokenizer
  17288.   $continuation_string_in_tokenizer
  17289.   $in_statement_continuation
  17290.   $started_looking_for_here_target_at
  17291.   $nearly_matched_here_target_at
  17292.  
  17293.   %is_indirect_object_taker
  17294.   %is_block_operator
  17295.   %expecting_operator_token
  17296.   %expecting_operator_types
  17297.   %expecting_term_types
  17298.   %expecting_term_token
  17299.   %is_block_function
  17300.   %is_block_list_function
  17301.   %is_digraph
  17302.   %is_file_test_operator
  17303.   %is_trigraph
  17304.   %is_valid_token_type
  17305.   %is_keyword
  17306.   %is_code_block_token
  17307.   %really_want_term
  17308.   @opening_brace_names
  17309.   @closing_brace_names
  17310.   %is_keyword_taking_list
  17311. };
  17312.  
  17313. # possible values of operator_expected()
  17314. use constant TERM     => -1;
  17315. use constant UNKNOWN  => 0;
  17316. use constant OPERATOR => 1;
  17317.  
  17318. # possible values of context
  17319. use constant SCALAR_CONTEXT  => -1;
  17320. use constant UNKNOWN_CONTEXT => 0;
  17321. use constant LIST_CONTEXT    => 1;
  17322.  
  17323. # Maximum number of little messages; probably need not be changed.
  17324. use constant MAX_NAG_MESSAGES => 6;
  17325.  
  17326. {
  17327.  
  17328.     # methods to count instances
  17329.     my $_count = 0;
  17330.     sub get_count        { $_count; }
  17331.     sub _increment_count { ++$_count }
  17332.     sub _decrement_count { --$_count }
  17333. }
  17334.  
  17335. sub DESTROY {
  17336.     $_[0]->_decrement_count();
  17337. }
  17338.  
  17339. sub new {
  17340.  
  17341.     my $class = shift;
  17342.  
  17343.     # Note: 'tabs' and 'indent_columns' are temporary and should be
  17344.     # removed asap
  17345.     my %defaults = (
  17346.         source_object       => undef,
  17347.         debugger_object     => undef,
  17348.         diagnostics_object  => undef,
  17349.         logger_object       => undef,
  17350.         starting_level      => undef,
  17351.         indent_columns      => 4,
  17352.         tabs                => 0,
  17353.         look_for_hash_bang  => 0,
  17354.         trim_qw             => 1,
  17355.         look_for_autoloader => 1,
  17356.         look_for_selfloader => 1,
  17357.     );
  17358.     my %args = ( %defaults, @_ );
  17359.  
  17360.     # we are given an object with a get_line() method to supply source lines
  17361.     my $source_object = $args{source_object};
  17362.  
  17363.     # we create another object with a get_line() and peek_ahead() method
  17364.     my $line_buffer_object = Perl::Tidy::LineBuffer->new($source_object);
  17365.  
  17366.     # Tokenizer state data is as follows:
  17367.     # _rhere_target_list    reference to list of here-doc targets
  17368.     # _here_doc_target      the target string for a here document
  17369.     # _here_quote_character the type of here-doc quoting (" ' ` or none)
  17370.     #                       to determine if interpolation is done
  17371.     # _quote_target         character we seek if chasing a quote
  17372.     # _line_start_quote     line where we started looking for a long quote
  17373.     # _in_here_doc          flag indicating if we are in a here-doc
  17374.     # _in_pod               flag set if we are in pod documentation
  17375.     # _in_error             flag set if we saw severe error (binary in script)
  17376.     # _in_data              flag set if we are in __DATA__ section
  17377.     # _in_end               flag set if we are in __END__ section
  17378.     # _in_format            flag set if we are in a format description
  17379.     # _in_quote             flag telling if we are chasing a quote
  17380.     # _starting_level       indentation level of first line
  17381.     # _input_tabstr         string denoting one indentation level of input file
  17382.     # _know_input_tabstr    flag indicating if we know _input_tabstr
  17383.     # _line_buffer_object   object with get_line() method to supply source code
  17384.     # _diagnostics_object   place to write debugging information
  17385.     $tokenizer_self = {
  17386.         _rhere_target_list    => undef,
  17387.         _in_here_doc          => 0,
  17388.         _here_doc_target      => "",
  17389.         _here_quote_character => "",
  17390.         _in_data              => 0,
  17391.         _in_end               => 0,
  17392.         _in_format            => 0,
  17393.         _in_error             => 0,
  17394.         _in_pod               => 0,
  17395.         _in_quote             => 0,
  17396.         _quote_target         => "",
  17397.         _line_start_quote     => -1,
  17398.         _starting_level       => $args{starting_level},
  17399.         _know_starting_level  => defined( $args{starting_level} ),
  17400.         _tabs                 => $args{tabs},
  17401.         _indent_columns       => $args{indent_columns},
  17402.         _look_for_hash_bang   => $args{look_for_hash_bang},
  17403.         _trim_qw              => $args{trim_qw},
  17404.         _input_tabstr         => "",
  17405.         _know_input_tabstr    => -1,
  17406.         _last_line_number     => 0,
  17407.         _saw_perl_dash_P      => 0,
  17408.         _saw_perl_dash_w      => 0,
  17409.         _saw_use_strict       => 0,
  17410.         _look_for_autoloader  => $args{look_for_autoloader},
  17411.         _look_for_selfloader  => $args{look_for_selfloader},
  17412.         _saw_autoloader       => 0,
  17413.         _saw_selfloader       => 0,
  17414.         _saw_hash_bang        => 0,
  17415.         _saw_end              => 0,
  17416.         _saw_data             => 0,
  17417.         _saw_lc_filehandle    => 0,
  17418.         _started_tokenizing   => 0,
  17419.         _line_buffer_object   => $line_buffer_object,
  17420.         _debugger_object      => $args{debugger_object},
  17421.         _diagnostics_object   => $args{diagnostics_object},
  17422.         _logger_object        => $args{logger_object},
  17423.     };
  17424.  
  17425.     prepare_for_a_new_file();
  17426.     find_starting_indentation_level();
  17427.  
  17428.     bless $tokenizer_self, $class;
  17429.  
  17430.     # This is not a full class yet, so die if an attempt is made to
  17431.     # create more than one object.
  17432.  
  17433.     if ( _increment_count() > 1 ) {
  17434.         confess
  17435. "Attempt to create more than 1 object in $class, which is not a true class yet\n";
  17436.     }
  17437.  
  17438.     return $tokenizer_self;
  17439.  
  17440. }
  17441.  
  17442. # interface to Perl::Tidy::Logger routines
  17443. sub warning {
  17444.     my $logger_object = $tokenizer_self->{_logger_object};
  17445.     if ($logger_object) {
  17446.         $logger_object->warning(@_);
  17447.     }
  17448. }
  17449.  
  17450. sub complain {
  17451.     my $logger_object = $tokenizer_self->{_logger_object};
  17452.     if ($logger_object) {
  17453.         $logger_object->complain(@_);
  17454.     }
  17455. }
  17456.  
  17457. sub write_logfile_entry {
  17458.     my $logger_object = $tokenizer_self->{_logger_object};
  17459.     if ($logger_object) {
  17460.         $logger_object->write_logfile_entry(@_);
  17461.     }
  17462. }
  17463.  
  17464. sub interrupt_logfile {
  17465.     my $logger_object = $tokenizer_self->{_logger_object};
  17466.     if ($logger_object) {
  17467.         $logger_object->interrupt_logfile();
  17468.     }
  17469. }
  17470.  
  17471. sub resume_logfile {
  17472.     my $logger_object = $tokenizer_self->{_logger_object};
  17473.     if ($logger_object) {
  17474.         $logger_object->resume_logfile();
  17475.     }
  17476. }
  17477.  
  17478. sub increment_brace_error {
  17479.     my $logger_object = $tokenizer_self->{_logger_object};
  17480.     if ($logger_object) {
  17481.         $logger_object->increment_brace_error();
  17482.     }
  17483. }
  17484.  
  17485. sub report_definite_bug {
  17486.     my $logger_object = $tokenizer_self->{_logger_object};
  17487.     if ($logger_object) {
  17488.         $logger_object->report_definite_bug();
  17489.     }
  17490. }
  17491.  
  17492. sub brace_warning {
  17493.     my $logger_object = $tokenizer_self->{_logger_object};
  17494.     if ($logger_object) {
  17495.         $logger_object->brace_warning(@_);
  17496.     }
  17497. }
  17498.  
  17499. sub get_saw_brace_error {
  17500.     my $logger_object = $tokenizer_self->{_logger_object};
  17501.     if ($logger_object) {
  17502.         $logger_object->get_saw_brace_error();
  17503.     }
  17504.     else {
  17505.         0;
  17506.     }
  17507. }
  17508.  
  17509. # interface to Perl::Tidy::Diagnostics routines
  17510. sub write_diagnostics {
  17511.     if ( $tokenizer_self->{_diagnostics_object} ) {
  17512.         $tokenizer_self->{_diagnostics_object}->write_diagnostics(@_);
  17513.     }
  17514. }
  17515.  
  17516. sub report_tokenization_errors {
  17517.  
  17518.     my $self = shift;
  17519.  
  17520.     my $level = get_indentation_level();
  17521.     if ( $level != $tokenizer_self->{_starting_level} ) {
  17522.         warning("final indentation level: $level\n");
  17523.     }
  17524.  
  17525.     check_final_nesting_depths();
  17526.  
  17527.     if ( $tokenizer_self->{_look_for_hash_bang}
  17528.         && !$tokenizer_self->{_saw_hash_bang} )
  17529.     {
  17530.         warning(
  17531.             "hit EOF without seeing hash-bang line; maybe don't need -x?\n");
  17532.     }
  17533.  
  17534.     if ( $tokenizer_self->{_in_format} ) {
  17535.         warning("hit EOF while in format description\n");
  17536.     }
  17537.  
  17538.     # this check may be removed after a year or so
  17539.     if ( $tokenizer_self->{_saw_lc_filehandle} ) {
  17540.  
  17541.         warning( <<'EOM' );
  17542. ------------------------------------------------------------------------
  17543. PLEASE NOTE: If you get this message, it is because perltidy noticed
  17544. possible ambiguous syntax at one or more places in your script, as
  17545. noted above.  The problem is with statements accepting indirect objects,
  17546. such as print and printf statements of the form
  17547.  
  17548.     print bareword ( $etc
  17549.  
  17550. Perltidy needs your help in deciding if 'bareword' is a filehandle or a
  17551. function call.  The problem is the space between 'bareword' and '('.  If
  17552. 'bareword' is a function call, you should remove the trailing space.  If
  17553. 'bareword' is a filehandle, you should avoid the opening paren or else
  17554. globally capitalize 'bareword' to be BAREWORD.  So the above line
  17555. would be: 
  17556.  
  17557.     print bareword( $etc    # function
  17558. or
  17559.     print bareword @list    # filehandle
  17560. or
  17561.     print BAREWORD ( $etc   # filehandle
  17562.  
  17563. If you want to keep the line as it is, and are sure it is correct,
  17564. you can use -w=0 to prevent this message.
  17565. ------------------------------------------------------------------------
  17566. EOM
  17567.  
  17568.     }
  17569.  
  17570.     if ( $tokenizer_self->{_in_pod} ) {
  17571.  
  17572.         # Just write log entry if this is after __END__ or __DATA__
  17573.         # because this happens to often, and it is not likely to be
  17574.         # a parsing error.
  17575.         if ( $tokenizer_self->{_saw_data} || $tokenizer_self->{_saw_end} ) {
  17576.             write_logfile_entry(
  17577. "hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
  17578.             );
  17579.         }
  17580.  
  17581.         else {
  17582.             complain(
  17583. "hit eof while in pod documentation (no =cut seen)\n\tthis can cause trouble with some pod utilities\n"
  17584.             );
  17585.         }
  17586.  
  17587.     }
  17588.  
  17589.     if ( $tokenizer_self->{_in_here_doc} ) {
  17590.         my $here_doc_target = $tokenizer_self->{_here_doc_target};
  17591.         if ($here_doc_target) {
  17592.             warning(
  17593. "hit EOF in here document starting at line $started_looking_for_here_target_at with target: $here_doc_target\n"
  17594.             );
  17595.         }
  17596.         else {
  17597.             warning(
  17598. "hit EOF in here document starting at line $started_looking_for_here_target_at with empty target string\n"
  17599.             );
  17600.         }
  17601.         if ($nearly_matched_here_target_at) {
  17602.             warning(
  17603. "NOTE: almost matched at input line $nearly_matched_here_target_at except for whitespace\n"
  17604.             );
  17605.         }
  17606.     }
  17607.  
  17608.     if ( $tokenizer_self->{_in_quote} ) {
  17609.         my $line_start_quote = $tokenizer_self->{_line_start_quote};
  17610.         my $quote_target     = $tokenizer_self->{_quote_target};
  17611.         warning(
  17612. "hit EOF seeking end of quote/pattern starting at line $line_start_quote ending in $quote_target\n"
  17613.         );
  17614.     }
  17615.  
  17616.     unless ( $tokenizer_self->{_saw_perl_dash_w} ) {
  17617.         if ( $] < 5.006 ) {
  17618.             write_logfile_entry("Suggest including '-w parameter'\n");
  17619.         }
  17620.         else {
  17621.             write_logfile_entry("Suggest including 'use warnings;'\n");
  17622.         }
  17623.     }
  17624.  
  17625.     if ( $tokenizer_self->{_saw_perl_dash_P} ) {
  17626.         write_logfile_entry("Use of -P parameter for defines is discouraged\n");
  17627.     }
  17628.  
  17629.     unless ( $tokenizer_self->{_saw_use_strict} ) {
  17630.         write_logfile_entry("Suggest including 'use strict;'\n");
  17631.     }
  17632.  
  17633.     # it is suggested that lables have at least one upper case character
  17634.     # for legibility and to avoid code breakage as new keywords are introduced
  17635.     if (@lower_case_labels_at) {
  17636.         my $num = @lower_case_labels_at;
  17637.         write_logfile_entry(
  17638.             "Suggest using upper case characters in label(s)\n");
  17639.         local $" = ')(';
  17640.         write_logfile_entry("  defined at line(s): (@lower_case_labels_at)\n");
  17641.     }
  17642. }
  17643.  
  17644. sub report_v_string {
  17645.  
  17646.     # warn if this version can't handle v-strings
  17647.     my $tok = shift;
  17648.     $saw_v_string = $input_line_number;
  17649.     if ( $] < 5.006 ) {
  17650.         warning(
  17651. "Found v-string '$tok' but v-strings are not implemented in your version of perl; see Camel 3 book ch 2\n"
  17652.         );
  17653.     }
  17654. }
  17655.  
  17656. sub get_input_line_number {
  17657.     return $tokenizer_self->{_last_line_number};
  17658. }
  17659.  
  17660. # returns the next tokenized line
  17661. sub get_line {
  17662.  
  17663.     my $self = shift;
  17664.  
  17665.     my $input_line = $tokenizer_self->{_line_buffer_object}->get_line();
  17666.  
  17667.     return undef unless ($input_line);
  17668.  
  17669.     $tokenizer_self->{_last_line_number}++;
  17670.  
  17671.     # remove any control m; otherwise here-target's may not match;
  17672.     # trimming trailing white space would work too, but that would
  17673.     # change the original line
  17674.     $input_line =~ s/(\r|\035)*$//gi;
  17675.  
  17676.     my $input_line_number = $tokenizer_self->{_last_line_number};
  17677.  
  17678.     # create a data structure describing this line which will be
  17679.     # returned to the caller.
  17680.  
  17681.     # _line_type codes are:
  17682.     #   SYSTEM         - system-specific code before hash-bang line
  17683.     #   CODE           - line of perl code (including comments)
  17684.     #   POD_START      - line starting pod, such as '=head'
  17685.     #   POD            - pod documentation text
  17686.     #   POD_END        - last line of pod section, '=cut'
  17687.     #   HERE           - text of here-document
  17688.     #   HERE_END       - last line of here-doc (target word)
  17689.     #   FORMAT         - format section
  17690.     #   FORMAT_END     - last line of format section, '.'
  17691.     #   DATA_START     - __DATA__ line
  17692.     #   DATA           - unidentified text following __DATA__
  17693.     #   END_START      - __END__ line
  17694.     #   END            - unidentified text following __END__
  17695.     #   ERROR          - we are in big trouble, probably not a perl script
  17696.  
  17697.     # Other variables:
  17698.     #   _curly_brace_depth     - depth of curly braces at start of line
  17699.     #   _square_bracket_depth  - depth of square brackets at start of line
  17700.     #   _paren_depth           - depth of parens at start of line
  17701.     #   _starting_in_quote     - this line continues a multi-line quote
  17702.     #                            (so don't trim leading blanks!)
  17703.     #   _ending_in_quote       - this line ends in a multi-line quote
  17704.     #                            (so don't trim trailing blanks!)
  17705.  
  17706.     my $line_of_tokens = {
  17707.         _line_type                => 'EOF',
  17708.         _line_text                => $input_line,
  17709.         _line_number              => $input_line_number,
  17710.         _rtoken_type              => undef,
  17711.         _rtokens                  => undef,
  17712.         _rlevels                  => undef,
  17713.         _rslevels                 => undef,
  17714.         _rblock_type              => undef,
  17715.         _rcontainer_type          => undef,
  17716.         _rcontainer_environment   => undef,
  17717.         _rtype_sequence           => undef,
  17718.         _rnesting_tokens          => undef,
  17719.         _rci_levels               => undef,
  17720.         _rnesting_blocks          => undef,
  17721.         _python_indentation_level => -1,                   ## 0,
  17722.         _starting_in_quote        =>
  17723.           ( $tokenizer_self->{_in_quote} && ( $quote_type eq 'Q' ) ),
  17724.         _ending_in_quote      => 0,
  17725.         _curly_brace_depth    => $brace_depth,
  17726.         _square_bracket_depth => $square_bracket_depth,
  17727.         _paren_depth          => $paren_depth,
  17728.         _quote_character      => '',
  17729.     };
  17730.  
  17731.     # must print line unchanged if we are in a here document
  17732.     if ( $tokenizer_self->{_in_here_doc} ) {
  17733.  
  17734.         $line_of_tokens->{_line_type} = 'HERE';
  17735.         my $here_doc_target      = $tokenizer_self->{_here_doc_target};
  17736.         my $here_quote_character = $tokenizer_self->{_here_quote_character};
  17737.         my $candidate_target     = $input_line;
  17738.         chomp $candidate_target;
  17739.         if ( $candidate_target eq $here_doc_target ) {
  17740.             $nearly_matched_here_target_at = undef;
  17741.             $line_of_tokens->{_line_type} = 'HERE_END';
  17742.             write_logfile_entry("Exiting HERE document $here_doc_target\n");
  17743.  
  17744.             my $rhere_target_list = $tokenizer_self->{_rhere_target_list};
  17745.             if (@$rhere_target_list) {    # there can be multiple here targets
  17746.                 ( $here_doc_target, $here_quote_character ) =
  17747.                   @{ shift @$rhere_target_list };
  17748.                 $tokenizer_self->{_here_doc_target}      = $here_doc_target;
  17749.                 $tokenizer_self->{_here_quote_character} =
  17750.                   $here_quote_character;
  17751.                 write_logfile_entry(
  17752.                     "Entering HERE document $here_doc_target\n");
  17753.                 $nearly_matched_here_target_at      = undef;
  17754.                 $started_looking_for_here_target_at = $input_line_number;
  17755.             }
  17756.             else {
  17757.                 $tokenizer_self->{_in_here_doc}          = 0;
  17758.                 $tokenizer_self->{_here_doc_target}      = "";
  17759.                 $tokenizer_self->{_here_quote_character} = "";
  17760.             }
  17761.         }
  17762.  
  17763.         # check for error of extra whitespace
  17764.         else {
  17765.             $candidate_target =~ s/\s*$//;
  17766.             $candidate_target =~ s/^\s*//;
  17767.             if ( $candidate_target eq $here_doc_target ) {
  17768.                 $nearly_matched_here_target_at = $input_line_number;
  17769.             }
  17770.         }
  17771.         return $line_of_tokens;
  17772.     }
  17773.  
  17774.     # must print line unchanged if we are in a format section
  17775.     elsif ( $tokenizer_self->{_in_format} ) {
  17776.  
  17777.         if ( $input_line =~ /^\.[\s#]*$/ ) {
  17778.             write_logfile_entry("Exiting format section\n");
  17779.             $tokenizer_self->{_in_format} = 0;
  17780.             $line_of_tokens->{_line_type} = 'FORMAT_END';
  17781.         }
  17782.         else {
  17783.             $line_of_tokens->{_line_type} = 'FORMAT';
  17784.         }
  17785.         return $line_of_tokens;
  17786.     }
  17787.  
  17788.     # must print line unchanged if we are in pod documentation
  17789.     elsif ( $tokenizer_self->{_in_pod} ) {
  17790.  
  17791.         $line_of_tokens->{_line_type} = 'POD';
  17792.         if ( $input_line =~ /^=cut/ ) {
  17793.             $line_of_tokens->{_line_type} = 'POD_END';
  17794.             write_logfile_entry("Exiting POD section\n");
  17795.             $tokenizer_self->{_in_pod} = 0;
  17796.         }
  17797.         if ( $input_line =~ /^\#\!.*perl\b/ ) {
  17798.             warning("Hash-bang in pod can cause perl to fail! \n");
  17799.         }
  17800.  
  17801.         return $line_of_tokens;
  17802.     }
  17803.  
  17804.     # must print line unchanged if we have seen a severe error (i.e., we
  17805.     # are seeing illegal tokens and connot continue.  Syntax errors do
  17806.     # not pass this route).  Calling routine can decide what to do, but
  17807.     # the default can be to just pass all lines as if they were after __END__
  17808.     elsif ( $tokenizer_self->{_in_error} ) {
  17809.         $line_of_tokens->{_line_type} = 'ERROR';
  17810.         return $line_of_tokens;
  17811.     }
  17812.  
  17813.     # print line unchanged if we are __DATA__ section
  17814.     elsif ( $tokenizer_self->{_in_data} ) {
  17815.  
  17816.         # ...but look for POD
  17817.         # Note that the _in_data and _in_end flags remain set
  17818.         # so that we return to that state after seeing the
  17819.         # end of a pod section
  17820.         if ( $input_line =~ /^=(?!cut)/ ) {
  17821.             $line_of_tokens->{_line_type} = 'POD_START';
  17822.             write_logfile_entry("Entering POD section\n");
  17823.             $tokenizer_self->{_in_pod} = 1;
  17824.             return $line_of_tokens;
  17825.         }
  17826.         else {
  17827.             $line_of_tokens->{_line_type} = 'DATA';
  17828.             return $line_of_tokens;
  17829.         }
  17830.     }
  17831.  
  17832.     # print line unchanged if we are in __END__ section
  17833.     elsif ( $tokenizer_self->{_in_end} ) {
  17834.  
  17835.         # ...but look for POD
  17836.         # Note that the _in_data and _in_end flags remain set
  17837.         # so that we return to that state after seeing the
  17838.         # end of a pod section
  17839.         if ( $input_line =~ /^=(?!cut)/ ) {
  17840.             $line_of_tokens->{_line_type} = 'POD_START';
  17841.             write_logfile_entry("Entering POD section\n");
  17842.             $tokenizer_self->{_in_pod} = 1;
  17843.             return $line_of_tokens;
  17844.         }
  17845.         else {
  17846.             $line_of_tokens->{_line_type} = 'END';
  17847.             return $line_of_tokens;
  17848.         }
  17849.     }
  17850.  
  17851.     # check for a hash-bang line if we haven't seen one
  17852.     if ( !$tokenizer_self->{_saw_hash_bang} ) {
  17853.         if ( $input_line =~ /^\#\!.*perl\b/ ) {
  17854.             $tokenizer_self->{_saw_hash_bang} = $input_line_number;
  17855.  
  17856.             # check for -w and -P flags
  17857.             if ( $input_line =~ /^\#\!.*perl\s.*-.*P/ ) {
  17858.                 $tokenizer_self->{_saw_perl_dash_P} = 1;
  17859.             }
  17860.  
  17861.             if ( $input_line =~ /^\#\!.*perl\s.*-.*w/ ) {
  17862.                 $tokenizer_self->{_saw_perl_dash_w} = 1;
  17863.             }
  17864.  
  17865.             if (   ( $input_line_number > 1 )
  17866.                 && ( !$tokenizer_self->{_look_for_hash_bang} ) )
  17867.             {
  17868.  
  17869.                 # this is helpful for VMS systems; we may have accidentally
  17870.                 # tokenized some DCL commands
  17871.                 if ( $tokenizer_self->{_started_tokenizing} ) {
  17872.                     warning(
  17873. "There seems to be a hash-bang after line 1; do you need to run with -x ?\n"
  17874.                     );
  17875.                 }
  17876.                 else {
  17877.                     complain("Useless hash-bang after line 1\n");
  17878.                 }
  17879.             }
  17880.  
  17881.             # Report the leading hash-bang as a system line
  17882.             # This will prevent -dac from deleting it
  17883.             else {
  17884.                 $line_of_tokens->{_line_type} = 'SYSTEM';
  17885.                 return $line_of_tokens;
  17886.             }
  17887.         }
  17888.     }
  17889.  
  17890.     # wait for a hash-bang before parsing if the user invoked us with -x
  17891.     if ( $tokenizer_self->{_look_for_hash_bang}
  17892.         && !$tokenizer_self->{_saw_hash_bang} )
  17893.     {
  17894.         $line_of_tokens->{_line_type} = 'SYSTEM';
  17895.         return $line_of_tokens;
  17896.     }
  17897.  
  17898.     # a first line of the form ': #' will be marked as SYSTEM
  17899.     # since lines of this form may be used by tcsh
  17900.     if ( $input_line_number == 1 && $input_line =~ /^\s*\:\s*\#/ ) {
  17901.         $line_of_tokens->{_line_type} = 'SYSTEM';
  17902.         return $line_of_tokens;
  17903.     }
  17904.  
  17905.     # now we know that it is ok to tokenize the line...
  17906.     # the line tokenizer will modify any of these private variables:
  17907.     #        _rhere_target_list
  17908.     #        _in_data
  17909.     #        _in_end
  17910.     #        _in_format
  17911.     #        _in_error
  17912.     #        _in_pod
  17913.     #        _in_quote
  17914.     my $ending_in_quote_last = $tokenizer_self->{_in_quote};
  17915.     tokenize_this_line($line_of_tokens);
  17916.  
  17917.     # Now finish defining the return structure and return it
  17918.     $line_of_tokens->{_ending_in_quote} = $tokenizer_self->{_in_quote};
  17919.  
  17920.     # handle severe error (binary data in script)
  17921.     if ( $tokenizer_self->{_in_error} ) {
  17922.         $tokenizer_self->{_in_quote} = 0;    # to avoid any more messages
  17923.         warning("Giving up after error\n");
  17924.         $line_of_tokens->{_line_type} = 'ERROR';
  17925.         reset_indentation_level(0);          # avoid error messages
  17926.         return $line_of_tokens;
  17927.     }
  17928.  
  17929.     # handle start of pod documentation
  17930.     if ( $tokenizer_self->{_in_pod} ) {
  17931.  
  17932.         # This gets tricky..above a __DATA__ or __END__ section, perl
  17933.         # accepts '=cut' as the start of pod section. But afterwards,
  17934.         # only pod utilities see it and they may ignore an =cut without
  17935.         # leading =head.  In any case, this isn't good.
  17936.         if ( $input_line =~ /^=cut\b/ ) {
  17937.             if ( $tokenizer_self->{_saw_data} || $tokenizer_self->{_saw_end} ) {
  17938.                 complain("=cut while not in pod ignored\n");
  17939.                 $tokenizer_self->{_in_pod}    = 0;
  17940.                 $line_of_tokens->{_line_type} = 'POD_STOP';
  17941.             }
  17942.             else {
  17943.                 $line_of_tokens->{_line_type} = 'POD_END';
  17944.                 complain(
  17945. "=cut starts a pod section .. this can fool pod utilities.\n"
  17946.                 );
  17947.                 write_logfile_entry("Entering POD section\n");
  17948.             }
  17949.         }
  17950.  
  17951.         else {
  17952.             $line_of_tokens->{_line_type} = 'POD_START';
  17953.             write_logfile_entry("Entering POD section\n");
  17954.         }
  17955.  
  17956.         return $line_of_tokens;
  17957.     }
  17958.  
  17959.     # update indentation levels for log messages
  17960.     if ( $input_line !~ /^\s*$/ ) {
  17961.         my $rlevels                      = $line_of_tokens->{_rlevels};
  17962.         my $structural_indentation_level = $$rlevels[0];
  17963.         my ( $python_indentation_level, $msg ) =
  17964.           find_indentation_level( $input_line, $structural_indentation_level );
  17965.         if ($msg) { write_logfile_entry("$msg") }
  17966.         if ( $tokenizer_self->{_know_input_tabstr} == 1 ) {
  17967.             $line_of_tokens->{_python_indentation_level} =
  17968.               $python_indentation_level;
  17969.         }
  17970.     }
  17971.  
  17972.     # see if this line contains here doc targets
  17973.     my $rhere_target_list = $tokenizer_self->{_rhere_target_list};
  17974.     if (@$rhere_target_list) {
  17975.  
  17976.         #my $here_doc_target = shift @$rhere_target_list;
  17977.         my ( $here_doc_target, $here_quote_character ) =
  17978.           @{ shift @$rhere_target_list };
  17979.         $tokenizer_self->{_in_here_doc}          = 1;
  17980.         $tokenizer_self->{_here_doc_target}      = $here_doc_target;
  17981.         $tokenizer_self->{_here_quote_character} = $here_quote_character;
  17982.         write_logfile_entry("Entering HERE document $here_doc_target\n");
  17983.         $started_looking_for_here_target_at = $input_line_number;
  17984.     }
  17985.  
  17986.     # NOTE: __END__ and __DATA__ statements are written unformatted
  17987.     # because they can theoretically contain additional characters
  17988.     # which are not tokenized (and cannot be read with <DATA> either!).
  17989.     if ( $tokenizer_self->{_in_data} ) {
  17990.         $line_of_tokens->{_line_type} = 'DATA_START';
  17991.         write_logfile_entry("Starting __DATA__ section\n");
  17992.         $tokenizer_self->{_saw_data} = 1;
  17993.  
  17994.         # keep parsing after __DATA__ if use SelfLoader was seen
  17995.         if ( $tokenizer_self->{_saw_selfloader} ) {
  17996.             $tokenizer_self->{_in_data} = 0;
  17997.             write_logfile_entry(
  17998.                 "SelfLoader seen, continuing; -nlsl deactivates\n");
  17999.         }
  18000.  
  18001.         return $line_of_tokens;
  18002.     }
  18003.  
  18004.     elsif ( $tokenizer_self->{_in_end} ) {
  18005.         $line_of_tokens->{_line_type} = 'END_START';
  18006.         write_logfile_entry("Starting __END__ section\n");
  18007.         $tokenizer_self->{_saw_end} = 1;
  18008.  
  18009.         # keep parsing after __END__ if use AutoLoader was seen
  18010.         if ( $tokenizer_self->{_saw_autoloader} ) {
  18011.             $tokenizer_self->{_in_end} = 0;
  18012.             write_logfile_entry(
  18013.                 "AutoLoader seen, continuing; -nlal deactivates\n");
  18014.         }
  18015.         return $line_of_tokens;
  18016.     }
  18017.  
  18018.     # now, finally, we know that this line is type 'CODE'
  18019.     $line_of_tokens->{_line_type} = 'CODE';
  18020.  
  18021.     # remember if we have seen any real code
  18022.     if (   !$tokenizer_self->{_started_tokenizing}
  18023.         && $input_line !~ /^\s*$/
  18024.         && $input_line !~ /^\s*#/ )
  18025.     {
  18026.         $tokenizer_self->{_started_tokenizing} = 1;
  18027.     }
  18028.  
  18029.     if ( $tokenizer_self->{_debugger_object} ) {
  18030.         $tokenizer_self->{_debugger_object}->write_debug_entry($line_of_tokens);
  18031.     }
  18032.  
  18033.     # Note: if keyword 'format' occurs in this line code, it is still CODE
  18034.     # (keyword 'format' need not start a line)
  18035.     if ( $tokenizer_self->{_in_format} ) {
  18036.         write_logfile_entry("Entering format section\n");
  18037.     }
  18038.  
  18039.     if ( $tokenizer_self->{_in_quote}
  18040.         and ( $tokenizer_self->{_line_start_quote} < 0 ) )
  18041.     {
  18042.  
  18043.         if ( ( my $quote_target = get_quote_target() ) !~ /^\s*$/ ) {
  18044.             $tokenizer_self->{_line_start_quote} = $input_line_number;
  18045.             $tokenizer_self->{_quote_target}     = $quote_target;
  18046.             write_logfile_entry(
  18047.                 "Start multi-line quote or pattern ending in $quote_target\n");
  18048.         }
  18049.     }
  18050.     elsif ( ( $tokenizer_self->{_line_start_quote} >= 0 )
  18051.         and !$tokenizer_self->{_in_quote} )
  18052.     {
  18053.         $tokenizer_self->{_line_start_quote} = -1;
  18054.         write_logfile_entry("End of multi-line quote or pattern\n");
  18055.     }
  18056.  
  18057.     # we are returning a line of CODE
  18058.     return $line_of_tokens;
  18059. }
  18060.  
  18061. sub find_starting_indentation_level {
  18062.  
  18063.     my $starting_level    = 0;
  18064.     my $know_input_tabstr = -1;    # flag for find_indentation_level
  18065.  
  18066.     # use value if given as parameter
  18067.     if ( $tokenizer_self->{_know_starting_level} ) {
  18068.         $starting_level = $tokenizer_self->{_starting_level};
  18069.     }
  18070.  
  18071.     # if we know there is a hash_bang line, the level must be zero
  18072.     elsif ( $tokenizer_self->{_look_for_hash_bang} ) {
  18073.         $tokenizer_self->{_know_starting_level} = 1;
  18074.     }
  18075.  
  18076.     # otherwise figure it out from the input file
  18077.     else {
  18078.         my $line;
  18079.         my $i                            = 0;
  18080.         my $structural_indentation_level = -1; # flag for find_indentation_level
  18081.  
  18082.         my $msg = "";
  18083.         while ( $line =
  18084.             $tokenizer_self->{_line_buffer_object}->peek_ahead( $i++ ) )
  18085.         {
  18086.  
  18087.             # if first line is #! then assume starting level is zero
  18088.             if ( $i == 1 && $line =~ /^\#\!/ ) {
  18089.                 $starting_level = 0;
  18090.                 last;
  18091.             }
  18092.             next if ( $line =~ /^\s*#/ );      # must not be comment
  18093.             next if ( $line =~ /^\s*$/ );      # must not be blank
  18094.             ( $starting_level, $msg ) =
  18095.               find_indentation_level( $line, $structural_indentation_level );
  18096.             if ($msg) { write_logfile_entry("$msg") }
  18097.             last;
  18098.         }
  18099.         $msg = "Line $i implies starting-indentation-level = $starting_level\n";
  18100.  
  18101.         if ( $starting_level > 0 ) {
  18102.  
  18103.             my $input_tabstr = $tokenizer_self->{_input_tabstr};
  18104.             if ( $input_tabstr eq "\t" ) {
  18105.                 $msg .= "by guessing input tabbing uses 1 tab per level\n";
  18106.             }
  18107.             else {
  18108.                 my $cols = length($input_tabstr);
  18109.                 $msg .=
  18110.                   "by guessing input tabbing uses $cols blanks per level\n";
  18111.             }
  18112.         }
  18113.         write_logfile_entry("$msg");
  18114.     }
  18115.     $tokenizer_self->{_starting_level} = $starting_level;
  18116.     reset_indentation_level($starting_level);
  18117. }
  18118.  
  18119. # Find indentation level given a input line.  At the same time, try to
  18120. # figure out the input tabbing scheme.
  18121. #
  18122. # There are two types of calls:
  18123. #
  18124. # Type 1: $structural_indentation_level < 0
  18125. #  In this case we have to guess $input_tabstr to figure out the level.
  18126. #
  18127. # Type 2: $structural_indentation_level >= 0
  18128. #  In this case the level of this line is known, and this routine can
  18129. #  update the tabbing string, if still unknown, to make the level correct.
  18130.  
  18131. sub find_indentation_level {
  18132.     my ( $line, $structural_indentation_level ) = @_;
  18133.     my $level = 0;
  18134.     my $msg   = "";
  18135.  
  18136.     my $know_input_tabstr = $tokenizer_self->{_know_input_tabstr};
  18137.     my $input_tabstr      = $tokenizer_self->{_input_tabstr};
  18138.  
  18139.     # find leading whitespace
  18140.     my $leading_whitespace = ( $line =~ /^(\s*)/ ) ? $1 : "";
  18141.  
  18142.     # make first guess at input tabbing scheme if necessary
  18143.     if ( $know_input_tabstr < 0 ) {
  18144.  
  18145.         $know_input_tabstr = 0;
  18146.  
  18147.         if ( $tokenizer_self->{_tabs} ) {
  18148.             $input_tabstr = "\t";
  18149.             if ( length($leading_whitespace) > 0 ) {
  18150.                 if ( $leading_whitespace !~ /\t/ ) {
  18151.  
  18152.                     my $cols = $tokenizer_self->{_indent_columns};
  18153.  
  18154.                     if ( length($leading_whitespace) < $cols ) {
  18155.                         $cols = length($leading_whitespace);
  18156.                     }
  18157.                     $input_tabstr = " " x $cols;
  18158.                 }
  18159.             }
  18160.         }
  18161.         else {
  18162.             $input_tabstr = " " x $tokenizer_self->{_indent_columns};
  18163.  
  18164.             if ( length($leading_whitespace) > 0 ) {
  18165.                 if ( $leading_whitespace =~ /^\t/ ) {
  18166.                     $input_tabstr = "\t";
  18167.                 }
  18168.             }
  18169.         }
  18170.         $tokenizer_self->{_know_input_tabstr} = $know_input_tabstr;
  18171.         $tokenizer_self->{_input_tabstr}      = $input_tabstr;
  18172.     }
  18173.  
  18174.     # determine the input tabbing scheme if possible
  18175.     if (   ( $know_input_tabstr == 0 )
  18176.         && ( length($leading_whitespace) > 0 )
  18177.         && ( $structural_indentation_level > 0 ) )
  18178.     {
  18179.         my $saved_input_tabstr = $input_tabstr;
  18180.  
  18181.         # check for common case of one tab per indentation level
  18182.         if ( $leading_whitespace eq "\t" x $structural_indentation_level ) {
  18183.             if ( $leading_whitespace eq "\t" x $structural_indentation_level ) {
  18184.                 $input_tabstr = "\t";
  18185.                 $msg          = "Guessing old indentation was tab character\n";
  18186.             }
  18187.         }
  18188.  
  18189.         else {
  18190.  
  18191.             # detab any tabs based on 8 blanks per tab
  18192.             my $entabbed = "";
  18193.             if ( $leading_whitespace =~ s/^\t+/        /g ) {
  18194.                 $entabbed = "entabbed";
  18195.             }
  18196.  
  18197.             # now compute tabbing from number of spaces
  18198.             my $columns =
  18199.               length($leading_whitespace) / $structural_indentation_level;
  18200.             if ( $columns == int $columns ) {
  18201.                 $msg =
  18202.                   "Guessing old indentation was $columns $entabbed spaces\n";
  18203.             }
  18204.             else {
  18205.                 $columns = int $columns;
  18206.                 $msg     =
  18207. "old indentation is unclear, using $columns $entabbed spaces\n";
  18208.             }
  18209.             $input_tabstr = " " x $columns;
  18210.         }
  18211.         $know_input_tabstr                    = 1;
  18212.         $tokenizer_self->{_know_input_tabstr} = $know_input_tabstr;
  18213.         $tokenizer_self->{_input_tabstr}      = $input_tabstr;
  18214.  
  18215.         # see if mistakes were made
  18216.         if ( ( $tokenizer_self->{_starting_level} > 0 )
  18217.             && !$tokenizer_self->{_know_starting_level} )
  18218.         {
  18219.  
  18220.             if ( $input_tabstr ne $saved_input_tabstr ) {
  18221.                 complain(
  18222. "I made a bad starting level guess; rerun with a value for -sil \n"
  18223.                 );
  18224.             }
  18225.         }
  18226.     }
  18227.  
  18228.     # use current guess at input tabbing to get input indentation level
  18229.     #
  18230.     # Patch to handle a common case of entabbed leading whitespace
  18231.     # If the leading whitespace equals 4 spaces and we also have
  18232.     # tabs, detab the input whitespace assuming 8 spaces per tab.
  18233.     if ( length($input_tabstr) == 4 ) {
  18234.         $leading_whitespace =~ s/^\t+/        /g;
  18235.     }
  18236.  
  18237.     if ( ( my $len_tab = length($input_tabstr) ) > 0 ) {
  18238.         my $pos = 0;
  18239.  
  18240.         while ( substr( $leading_whitespace, $pos, $len_tab ) eq $input_tabstr )
  18241.         {
  18242.             $pos += $len_tab;
  18243.             $level++;
  18244.         }
  18245.     }
  18246.     return ( $level, $msg );
  18247. }
  18248.  
  18249. sub dump_token_types {
  18250.     my $class = shift;
  18251.     my $fh    = shift;
  18252.  
  18253.     # This should be the latest list of token types in use
  18254.     # adding NEW_TOKENS: add a comment here
  18255.     print $fh <<'END_OF_LIST';
  18256.  
  18257. Here is a list of the token types currently used.  
  18258. For the following tokens, the "type" of a token is just the token itself.  
  18259.  
  18260. .. :: << >> ** && .. ||  -> => += -= .= %= &= |= ^= *= <>
  18261. ( ) <= >= == =~ !~ != ++ -- /= x=
  18262. ... **= <<= >>= &&= ||= <=> 
  18263. , + - / * | % ! x ~ = \ ? : . < > ^ &
  18264.  
  18265. The following additional token types are defined:
  18266.  
  18267.  type    meaning
  18268.     b    blank (white space) 
  18269.     {    indent: opening structural curly brace or square bracket or paren
  18270.          (code block, anonymous hash reference, or anonymous array reference)
  18271.     }    outdent: right structural curly brace or square bracket or paren
  18272.     [    left non-structural square bracket (enclosing an array index)
  18273.     ]    right non-structural square bracket
  18274.     (    left non-structural paren (all but a list right of an =)
  18275.     )    right non-structural parena
  18276.     L    left non-structural curly brace (enclosing a key)
  18277.     R    right non-structural curly brace 
  18278.     ;    terminal semicolon
  18279.     f    indicates a semicolon in a "for" statement
  18280.     h    here_doc operator <<
  18281.     #    a comment
  18282.     Q    indicates a quote or pattern
  18283.     q    indicates a qw quote block
  18284.     k    a perl keyword
  18285.     C    user-defined constant or constant function (with void prototype = ())
  18286.     U    user-defined function taking parameters
  18287.     G    user-defined function taking block parameter (like grep/map/eval)
  18288.     M    (unused, but reserved for subroutine definition name)
  18289.     P    (unused, but -html uses it to label pod text)
  18290.     t    type indicater such as %,$,@,*,&,sub
  18291.     w    bare word (perhaps a subroutine call)
  18292.     i    identifier of some type (with leading %, $, @, *, &, sub )
  18293.     n    a number
  18294.     v    a v-string
  18295.     F    a file test operator (like -e)
  18296.     Y    File handle
  18297.     Z    identifier in indirect object slot: may be file handle, object
  18298.     J    LABEL:  code block label
  18299.     j    LABEL after next, last, redo, goto
  18300.     p    unary +
  18301.     m    unary -
  18302.     pp   pre-increment operator ++
  18303.     mm   pre-decrement operator -- 
  18304.     A    : used as attribute separator
  18305. END_OF_LIST
  18306. }
  18307.  
  18308. # This is a currently unused debug routine
  18309. sub dump_functions {
  18310.  
  18311.     my $fh = *STDOUT;
  18312.     my ( $pkg, $sub );
  18313.     foreach $pkg ( keys %is_user_function ) {
  18314.         print $fh "\nnon-constant subs in package $pkg\n";
  18315.  
  18316.         foreach $sub ( keys %{ $is_user_function{$pkg} } ) {
  18317.             my $msg = "";
  18318.             if ( $is_block_list_function{$pkg}{$sub} ) {
  18319.                 $msg = 'block_list';
  18320.             }
  18321.  
  18322.             if ( $is_block_function{$pkg}{$sub} ) {
  18323.                 $msg = 'block';
  18324.             }
  18325.             print $fh "$sub $msg\n";
  18326.         }
  18327.     }
  18328.  
  18329.     foreach $pkg ( keys %is_constant ) {
  18330.         print $fh "\nconstants and constant subs in package $pkg\n";
  18331.  
  18332.         foreach $sub ( keys %{ $is_constant{$pkg} } ) {
  18333.             print $fh "$sub\n";
  18334.         }
  18335.     }
  18336. }
  18337.  
  18338. sub prepare_for_a_new_file {
  18339.     $saw_negative_indentation = 0;
  18340.     $id_scan_state            = '';
  18341.     $statement_type           = '';     # '' or 'use' or 'sub..' or 'case..'
  18342.     $last_nonblank_token      = ';';    # the only possible starting state which
  18343.     $last_nonblank_type       = ';';    # will make a leading brace a code block
  18344.     $last_nonblank_block_type = '';
  18345.     $last_nonblank_container_type      = '';
  18346.     $last_nonblank_type_sequence       = '';
  18347.     $last_last_nonblank_token          = ';';
  18348.     $last_last_nonblank_type           = ';';
  18349.     $last_last_nonblank_block_type     = '';
  18350.     $last_last_nonblank_container_type = '';
  18351.     $last_last_nonblank_type_sequence  = '';
  18352.     $last_nonblank_prototype           = "";
  18353.     $identifier                        = '';
  18354.     $in_quote   = 0;     # flag telling if we are chasing a quote, and what kind
  18355.     $quote_type = 'Q';
  18356.     $quote_character = "";    # character we seek if chasing a quote
  18357.     $quote_pos   = 0;  # next character index to check for case of alphanum char
  18358.     $quote_depth = 0;
  18359.     $allowed_quote_modifiers                     = "";
  18360.     $paren_depth                                 = 0;
  18361.     $brace_depth                                 = 0;
  18362.     $square_bracket_depth                        = 0;
  18363.     $current_package                             = "main";
  18364.     @current_depth[ 0 .. $#closing_brace_names ] =
  18365.       (0) x scalar @closing_brace_names;
  18366.     @nesting_sequence_number[ 0 .. $#closing_brace_names ] =
  18367.       ( 0 .. $#closing_brace_names );
  18368.     @current_sequence_number = ();
  18369.  
  18370.     $paren_type[$paren_depth]            = '';
  18371.     $paren_semicolon_count[$paren_depth] = 0;
  18372.     $brace_type[$brace_depth] = ';';    # identify opening brace as code block
  18373.     $brace_structural_type[$brace_depth]                   = '';
  18374.     $brace_statement_type[$brace_depth]                    = "";
  18375.     $brace_context[$brace_depth]                           = UNKNOWN_CONTEXT;
  18376.     $paren_structural_type[$brace_depth]                   = '';
  18377.     $square_bracket_type[$square_bracket_depth]            = '';
  18378.     $square_bracket_structural_type[$square_bracket_depth] = '';
  18379.     $brace_package[$paren_depth]                           = $current_package;
  18380.     %is_constant                      = ();             # user-defined constants
  18381.     %is_user_function                 = ();             # user-defined functions
  18382.     %user_function_prototype          = ();             # their prototypes
  18383.     %is_block_function                = ();
  18384.     %is_block_list_function           = ();
  18385.     %saw_function_definition          = ();
  18386.     $unexpected_error_count           = 0;
  18387.     $want_paren                       = "";
  18388.     $context                          = UNKNOWN_CONTEXT;
  18389.     @slevel_stack                     = ();
  18390.     $ci_string_in_tokenizer           = "";
  18391.     $continuation_string_in_tokenizer = "0";
  18392.     $in_statement_continuation        = 0;
  18393.     @lower_case_labels_at             = ();
  18394.     $saw_v_string         = 0;      # for warning of v-strings on older perl
  18395.     $nesting_token_string = "";
  18396.     $nesting_type_string  = "";
  18397.     $nesting_block_string = '1';    # initially in a block
  18398.     $nesting_block_flag   = 1;
  18399.     $nesting_list_string  = '0';    # initially not in a list
  18400.     $nesting_list_flag    = 0;      # initially not in a list
  18401.     $nearly_matched_here_target_at = undef;
  18402. }
  18403.  
  18404. sub get_quote_target {
  18405.     return matching_end_token($quote_character);
  18406. }
  18407.  
  18408. sub get_indentation_level {
  18409.     return $level_in_tokenizer;
  18410. }
  18411.  
  18412. sub reset_indentation_level {
  18413.     $level_in_tokenizer  = $_[0];
  18414.     $slevel_in_tokenizer = $_[0];
  18415.     push @slevel_stack, $slevel_in_tokenizer;
  18416. }
  18417.  
  18418. {    # begin tokenize_this_line
  18419.  
  18420.     use constant BRACE          => 0;
  18421.     use constant SQUARE_BRACKET => 1;
  18422.     use constant PAREN          => 2;
  18423.     use constant QUESTION_COLON => 3;
  18424.  
  18425.     my (
  18426.         $block_type,      $container_type,       $expecting,
  18427.         $here_doc_target, $here_quote_character, $i,
  18428.         $i_tok,           $last_nonblank_i,      $next_tok,
  18429.         $next_type,       $prototype,            $rtoken_map,
  18430.         $rtoken_type,     $rtokens,              $tok,
  18431.         $type,            $type_sequence,
  18432.     );
  18433.  
  18434.     my @here_target_list = ();    # list of here-doc target strings
  18435.  
  18436.     # ------------------------------------------------------------
  18437.     # beginning of various scanner interfaces to simplify coding
  18438.     # ------------------------------------------------------------
  18439.     sub scan_bare_identifier {
  18440.         ( $i, $tok, $type, $prototype ) =
  18441.           scan_bare_identifier_do( $input_line, $i, $tok, $type, $prototype,
  18442.             $rtoken_map );
  18443.     }
  18444.  
  18445.     sub scan_identifier {
  18446.         ( $i, $tok, $type, $id_scan_state, $identifier ) =
  18447.           scan_identifier_do( $i, $id_scan_state, $identifier, $rtokens );
  18448.     }
  18449.  
  18450.     sub scan_id {
  18451.         ( $i, $tok, $type, $id_scan_state ) =
  18452.           scan_id_do( $input_line, $i, $tok, $rtokens, $rtoken_map,
  18453.             $id_scan_state );
  18454.     }
  18455.  
  18456.     my $number;
  18457.  
  18458.     sub scan_number {
  18459.         ( $i, $type, $number ) =
  18460.           scan_number_do( $input_line, $i, $rtoken_map, $type );
  18461.     }
  18462.  
  18463.     # a sub to warn if token found where term expected
  18464.     sub error_if_expecting_TERM {
  18465.         if ( $expecting == TERM ) {
  18466.             if ( $really_want_term{$last_nonblank_type} ) {
  18467.                 unexpected( $tok, "term", $i_tok, $last_nonblank_i );
  18468.                 1;
  18469.             }
  18470.         }
  18471.     }
  18472.  
  18473.     # a sub to warn if token found where operator expected
  18474.     sub error_if_expecting_OPERATOR {
  18475.         if ( $expecting == OPERATOR ) {
  18476.             my $thing = defined $_[0] ? $_[0] : $tok;
  18477.             unexpected( $thing, "operator", $i_tok, $last_nonblank_i );
  18478.             if ( $i_tok == 0 ) {
  18479.                 interrupt_logfile();
  18480.                 warning("Missing ';' above?\n");
  18481.                 resume_logfile();
  18482.             }
  18483.             1;
  18484.         }
  18485.     }
  18486.  
  18487.     # ------------------------------------------------------------
  18488.     # end scanner interfaces
  18489.     # ------------------------------------------------------------
  18490.  
  18491.     my %is_for_foreach;
  18492.     @_ = qw(for foreach);
  18493.     @is_for_foreach{@_} = (1) x scalar(@_);
  18494.  
  18495.     my %is_my_our;
  18496.     @_ = qw(my our);
  18497.     @is_my_our{@_} = (1) x scalar(@_);
  18498.  
  18499.     # These keywords may introduce blocks after parenthesized expressions,
  18500.     # in the form:
  18501.     # keyword ( .... ) { BLOCK }
  18502.     # patch for SWITCH/CASE: added 'switch' 'case' 'given' 'when'
  18503.     my %is_blocktype_with_paren;
  18504.     @_ = qw(if elsif unless while until for foreach switch case given when);
  18505.     @is_blocktype_with_paren{@_} = (1) x scalar(@_);
  18506.  
  18507.     # ------------------------------------------------------------
  18508.     # begin hash of code for handling most token types
  18509.     # ------------------------------------------------------------
  18510.     my $tokenization_code = {
  18511.  
  18512.         # no special code for these types yet, but syntax checks
  18513.         # could be added
  18514.  
  18515. ##      '!'   => undef,
  18516. ##      '!='  => undef,
  18517. ##      '!~'  => undef,
  18518. ##      '%='  => undef,
  18519. ##      '&&=' => undef,
  18520. ##      '&='  => undef,
  18521. ##      '+='  => undef,
  18522. ##      '-='  => undef,
  18523. ##      '..'  => undef,
  18524. ##      '..'  => undef,
  18525. ##      '...' => undef,
  18526. ##      '.='  => undef,
  18527. ##      '<<=' => undef,
  18528. ##      '<='  => undef,
  18529. ##      '<=>' => undef,
  18530. ##      '<>'  => undef,
  18531. ##      '='   => undef,
  18532. ##      '=='  => undef,
  18533. ##      '=~'  => undef,
  18534. ##      '>='  => undef,
  18535. ##      '>>'  => undef,
  18536. ##      '>>=' => undef,
  18537. ##      '\\'  => undef,
  18538. ##      '^='  => undef,
  18539. ##      '|='  => undef,
  18540. ##      '||=' => undef,
  18541. ##      '~'   => undef,
  18542.  
  18543.         '>' => sub {
  18544.             error_if_expecting_TERM()
  18545.               if ( $expecting == TERM );
  18546.         },
  18547.         '|' => sub {
  18548.             error_if_expecting_TERM()
  18549.               if ( $expecting == TERM );
  18550.         },
  18551.         '$' => sub {
  18552.  
  18553.             # start looking for a scalar
  18554.             error_if_expecting_OPERATOR("Scalar")
  18555.               if ( $expecting == OPERATOR );
  18556.             scan_identifier();
  18557.  
  18558.             if ( $identifier eq '$^W' ) {
  18559.                 $tokenizer_self->{_saw_perl_dash_w} = 1;
  18560.             }
  18561.  
  18562.             # Check for indentifier in indirect object slot
  18563.             # (vorboard.pl, sort.t).  Something like:
  18564.             #   /^(print|printf|sort|exec|system)$/
  18565.             if (
  18566.                 $is_indirect_object_taker{$last_nonblank_token}
  18567.  
  18568.                 || ( ( $last_nonblank_token eq '(' )
  18569.                     && $is_indirect_object_taker{ $paren_type[$paren_depth] } )
  18570.                 || ( $last_nonblank_type =~ /^[Uw]$/ )    # possible object
  18571.               )
  18572.             {
  18573.                 $type = 'Z';
  18574.             }
  18575.         },
  18576.         '(' => sub {
  18577.  
  18578.             ++$paren_depth;
  18579.             $paren_semicolon_count[$paren_depth] = 0;
  18580.             if ($want_paren) {
  18581.                 $container_type = $want_paren;
  18582.                 $want_paren     = "";
  18583.             }
  18584.             else {
  18585.                 $container_type = $last_nonblank_token;
  18586.  
  18587.                 # We can check for a syntax error here of unexpected '(',
  18588.                 # but this is going to get messy...
  18589.                 if (
  18590.                     $expecting == OPERATOR
  18591.  
  18592.                     # be sure this is not a method call of the form
  18593.                     # &method(...), $method->(..), &{method}(...)
  18594.                     # NOTE: at present, braces in something like &{ xxx }
  18595.                     # are not marked as a block, we might have a method call
  18596.                     && $last_nonblank_token !~ /^([\}\&]|\-\>)/
  18597.  
  18598.                   )
  18599.                 {
  18600.  
  18601.                     # ref: camel 3 p 703.
  18602.                     if ( $last_last_nonblank_token eq 'do' ) {
  18603.                         complain(
  18604. "do SUBROUTINE is deprecated; consider & or -> notation\n"
  18605.                         );
  18606.                     }
  18607.                     else {
  18608.  
  18609.                         # if this is an empty list, (), then it is not an
  18610.                         # error; for example, we might have a constant pi and
  18611.                         # invoke it with pi() or just pi;
  18612.                         my ( $next_nonblank_token, $i_next ) =
  18613.                           find_next_nonblank_token( $i, $rtokens );
  18614.                         if ( $next_nonblank_token ne ')' ) {
  18615.                             my $hint;
  18616.                             error_if_expecting_OPERATOR('(');
  18617.  
  18618.                             if ( $last_nonblank_type eq 'C' ) {
  18619.                                 $hint =
  18620.                                   "$last_nonblank_token has a void prototype\n";
  18621.                             }
  18622.                             elsif ( $last_nonblank_type eq 'i' ) {
  18623.                                 if (   $i_tok > 0
  18624.                                     && $last_nonblank_token =~ /^\$/ )
  18625.                                 {
  18626.                                     $hint =
  18627. "Do you mean '$last_nonblank_token->(' ?\n";
  18628.                                 }
  18629.                             }
  18630.                             if ($hint) {
  18631.                                 interrupt_logfile();
  18632.                                 warning($hint);
  18633.                                 resume_logfile();
  18634.                             }
  18635.                         } ## end if ( $next_nonblank_token...
  18636.                     } ## end else [ if ( $last_last_nonblank_token...
  18637.                 } ## end if ( $expecting == OPERATOR...
  18638.             }
  18639.             $paren_type[$paren_depth] = $container_type;
  18640.             $type_sequence = increase_nesting_depth( PAREN, $i_tok );
  18641.  
  18642.             # propagate types down through nested parens
  18643.             # for example: the second paren in 'if ((' would be structural
  18644.             # since the first is.
  18645.  
  18646.             if ( $last_nonblank_token eq '(' ) {
  18647.                 $type = $last_nonblank_type;
  18648.             }
  18649.  
  18650.             #     We exclude parens as structural after a ',' because it
  18651.             #     causes subtle problems with continuation indentation for
  18652.             #     something like this, where the first 'or' will not get
  18653.             #     indented.
  18654.             #
  18655.             #         assert(
  18656.             #             __LINE__,
  18657.             #             ( not defined $check )
  18658.             #               or ref $check
  18659.             #               or $check eq "new"
  18660.             #               or $check eq "old",
  18661.             #         );
  18662.             #
  18663.             #     Likewise, we exclude parens where a statement can start
  18664.             #     because of problems with continuation indentation, like
  18665.             #     these:
  18666.             #
  18667.             #         ($firstline =~ /^#\!.*perl/)
  18668.             #         and (print $File::Find::name, "\n")
  18669.             #           and (return 1);
  18670.             #
  18671.             #         (ref($usage_fref) =~ /CODE/)
  18672.             #         ? &$usage_fref
  18673.             #           : (&blast_usage, &blast_params, &blast_general_params);
  18674.  
  18675.             else {
  18676.                 $type = '{';
  18677.             }
  18678.  
  18679.             if ( $last_nonblank_type eq ')' ) {
  18680.                 warning(
  18681.                     "Syntax error? found token '$last_nonblank_type' then '('\n"
  18682.                 );
  18683.             }
  18684.             $paren_structural_type[$paren_depth] = $type;
  18685.  
  18686.         },
  18687.         ')' => sub {
  18688.             $type_sequence = decrease_nesting_depth( PAREN, $i_tok );
  18689.  
  18690.             if ( $paren_structural_type[$paren_depth] eq '{' ) {
  18691.                 $type = '}';
  18692.             }
  18693.  
  18694.             $container_type = $paren_type[$paren_depth];
  18695.  
  18696.             #    /^(for|foreach)$/
  18697.             if ( $is_for_foreach{ $paren_type[$paren_depth] } ) {
  18698.                 my $num_sc = $paren_semicolon_count[$paren_depth];
  18699.                 if ( $num_sc > 0 && $num_sc != 2 ) {
  18700.                     warning("Expected 2 ';' in 'for(;;)' but saw $num_sc\n");
  18701.                 }
  18702.             }
  18703.  
  18704.             if ( $paren_depth > 0 ) { $paren_depth-- }
  18705.         },
  18706.         ',' => sub {
  18707.             if ( $last_nonblank_type eq ',' ) {
  18708.                 complain("Repeated ','s \n");
  18709.             }
  18710. ##                FIXME: need to move this elsewhere, perhaps check after a '('
  18711. ##                elsif ($last_nonblank_token eq '(') {
  18712. ##                    warning("Leading ','s illegal in some versions of perl\n");
  18713. ##                }
  18714.         },
  18715.         ';' => sub {
  18716.             $context        = UNKNOWN_CONTEXT;
  18717.             $statement_type = '';
  18718.  
  18719.             #    /^(for|foreach)$/
  18720.             if ( $is_for_foreach{ $paren_type[$paren_depth] } )
  18721.             {    # mark ; in for loop
  18722.  
  18723.                 # Be careful: we do not want a semicolon such as the
  18724.                 # following to be included:
  18725.                 #
  18726.                 #    for (sort {strcoll($a,$b);} keys %investments) {
  18727.  
  18728.                 if (   $brace_depth == $depth_array[PAREN][BRACE][$paren_depth]
  18729.                     && $square_bracket_depth ==
  18730.                     $depth_array[PAREN][SQUARE_BRACKET][$paren_depth] )
  18731.                 {
  18732.  
  18733.                     $type = 'f';
  18734.                     $paren_semicolon_count[$paren_depth]++;
  18735.                 }
  18736.             }
  18737.  
  18738.         },
  18739.         '"' => sub {
  18740.             error_if_expecting_OPERATOR("String")
  18741.               if ( $expecting == OPERATOR );
  18742.             $in_quote                = 1;
  18743.             $type                    = 'Q';
  18744.             $allowed_quote_modifiers = "";
  18745.         },
  18746.         "'" => sub {
  18747.             error_if_expecting_OPERATOR("String")
  18748.               if ( $expecting == OPERATOR );
  18749.             $in_quote                = 1;
  18750.             $type                    = 'Q';
  18751.             $allowed_quote_modifiers = "";
  18752.         },
  18753.         '`' => sub {
  18754.             error_if_expecting_OPERATOR("String")
  18755.               if ( $expecting == OPERATOR );
  18756.             $in_quote                = 1;
  18757.             $type                    = 'Q';
  18758.             $allowed_quote_modifiers = "";
  18759.         },
  18760.         '/' => sub {
  18761.             my $is_pattern;
  18762.  
  18763.             if ( $expecting == UNKNOWN ) {    # indeterminte, must guess..
  18764.                 my $msg;
  18765.                 ( $is_pattern, $msg ) =
  18766.                   guess_if_pattern_or_division( $i, $rtokens, $rtoken_map );
  18767.  
  18768.                 if ($msg) {
  18769.                     write_diagnostics("DIVIDE:$msg\n");
  18770.                     write_logfile_entry($msg);
  18771.                 }
  18772.             }
  18773.             else { $is_pattern = ( $expecting == TERM ) }
  18774.  
  18775.             if ($is_pattern) {
  18776.                 $in_quote                = 1;
  18777.                 $type                    = 'Q';
  18778.                 $allowed_quote_modifiers = '[cgimosx]';
  18779.             }
  18780.             else {    # not a pattern; check for a /= token
  18781.  
  18782.                 if ( $$rtokens[ $i + 1 ] eq '=' ) {    # form token /=
  18783.                     $i++;
  18784.                     $tok  = '/=';
  18785.                     $type = $tok;
  18786.                 }
  18787.  
  18788.                 #DEBUG - collecting info on what tokens follow a divide
  18789.                 # for development of guessing algorithm
  18790.                 #if ( numerator_expected( $i, $rtokens ) < 0 ) {
  18791.                 #    #write_diagnostics( "DIVIDE? $input_line\n" );
  18792.                 #}
  18793.             }
  18794.         },
  18795.         '{' => sub {
  18796.  
  18797.             # if we just saw a ')', we will label this block with
  18798.             # its type.  We need to do this to allow sub
  18799.             # code_block_type to determine if this brace starts a
  18800.             # code block or anonymous hash.  (The type of a paren
  18801.             # pair is the preceding token, such as 'if', 'else',
  18802.             # etc).
  18803.             $container_type = "";
  18804.  
  18805.             # ATTRS: for a '{' following an attribute list, reset
  18806.             # things to look like we just saw the sub name
  18807.             if ( $statement_type =~ /^sub/ ) {
  18808.                 $last_nonblank_token = $statement_type;
  18809.                 $last_nonblank_type  = 'i';
  18810.                 $statement_type      = "";
  18811.             }
  18812.  
  18813.             # patch for SWITCH/CASE: hide these keywords from an immediately
  18814.             # following opening brace
  18815.             elsif ( ( $statement_type eq 'case' || $statement_type eq 'when' )
  18816.                 && $statement_type eq $last_nonblank_token )
  18817.             {
  18818.                 $last_nonblank_token = ";";
  18819.             }
  18820.  
  18821.             elsif ( $last_nonblank_token eq ')' ) {
  18822.                 $last_nonblank_token = $paren_type[ $paren_depth + 1 ];
  18823.  
  18824.                 # defensive move in case of a nesting error (pbug.t)
  18825.                 # in which this ')' had no previous '('
  18826.                 # this nesting error will have been caught
  18827.                 if ( !defined($last_nonblank_token) ) {
  18828.                     $last_nonblank_token = 'if';
  18829.                 }
  18830.  
  18831.                 # check for syntax error here;
  18832.                 unless ( $is_blocktype_with_paren{$last_nonblank_token} ) {
  18833.                     my $list = join ( ' ', sort keys %is_blocktype_with_paren );
  18834.                     warning(
  18835.                         "syntax error at ') {', didn't see one of: $list\n");
  18836.                 }
  18837.             }
  18838.  
  18839.             # patch for paren-less for/foreach glitch, part 2.
  18840.             # see note below under 'qw'
  18841.             elsif ($last_nonblank_token eq 'qw'
  18842.                 && $is_for_foreach{$want_paren} )
  18843.             {
  18844.                 $last_nonblank_token = $want_paren;
  18845.                 if ( $last_last_nonblank_token eq $want_paren ) {
  18846.                     warning(
  18847. "syntax error at '$want_paren .. {' -- missing \$ loop variable\n"
  18848.                     );
  18849.  
  18850.                 }
  18851.                 $want_paren = "";
  18852.             }
  18853.  
  18854.             # now identify which of the three possible types of
  18855.             # curly braces we have: hash index container, anonymous
  18856.             # hash reference, or code block.
  18857.  
  18858.             # non-structural (hash index) curly brace pair
  18859.             # get marked 'L' and 'R'
  18860.             if ( is_non_structural_brace() ) {
  18861.                 $type = 'L';
  18862.  
  18863.                 # patch for SWITCH/CASE:
  18864.                 # allow paren-less identifier after 'when'
  18865.                 # if the brace is preceded by a space
  18866.                 if (   $statement_type eq 'when'
  18867.                     && $last_nonblank_type      eq 'i'
  18868.                     && $last_last_nonblank_type eq 'k'
  18869.                     && ( $i_tok == 0 || $rtoken_type->[ $i_tok - 1 ] eq 'b' ) )
  18870.                 {
  18871.                     $type       = '{';
  18872.                     $block_type = $statement_type;
  18873.                 }
  18874.             }
  18875.  
  18876.             # code and anonymous hash have the same type, '{', but are
  18877.             # distinguished by 'block_type',
  18878.             # which will be blank for an anonymous hash
  18879.             else {
  18880.  
  18881.                 $block_type = code_block_type( $i_tok, $rtokens );
  18882.  
  18883.                 # patch for SWITCH/CASE: if we find a stray opening block brace
  18884.                 # where we might accept a 'case' or 'when' block, then take it
  18885.                 if (   $statement_type eq 'case'
  18886.                     || $statement_type eq 'when' )
  18887.                 {
  18888.                     if ( !$block_type || $block_type eq '}' ) {
  18889.                         $block_type = $statement_type;
  18890.                     }
  18891.                 }
  18892.             }
  18893.             $brace_type[ ++$brace_depth ] = $block_type;
  18894.             $brace_package[$brace_depth] = $current_package;
  18895.             $type_sequence = increase_nesting_depth( BRACE, $i_tok );
  18896.             $brace_structural_type[$brace_depth] = $type;
  18897.             $brace_context[$brace_depth]         = $context;
  18898.             $brace_statement_type[$brace_depth]  = $statement_type;
  18899.         },
  18900.         '}' => sub {
  18901.             $block_type = $brace_type[$brace_depth];
  18902.             if ($block_type) { $statement_type = '' }
  18903.             if ( defined( $brace_package[$brace_depth] ) ) {
  18904.                 $current_package = $brace_package[$brace_depth];
  18905.             }
  18906.  
  18907.             # can happen on brace error (caught elsewhere)
  18908.             else {
  18909.             }
  18910.             $type_sequence = decrease_nesting_depth( BRACE, $i_tok );
  18911.  
  18912.             if ( $brace_structural_type[$brace_depth] eq 'L' ) {
  18913.                 $type = 'R';
  18914.             }
  18915.  
  18916.             # propagate type information for 'do' and 'eval' blocks.
  18917.             # This is necessary to enable us to know if an operator
  18918.             # or term is expected next
  18919.             if ( $is_block_operator{ $brace_type[$brace_depth] } ) {
  18920.                 $tok = $brace_type[$brace_depth];
  18921.             }
  18922.  
  18923.             $context        = $brace_context[$brace_depth];
  18924.             $statement_type = $brace_statement_type[$brace_depth];
  18925.             if ( $brace_depth > 0 ) { $brace_depth--; }
  18926.         },
  18927.         '&' => sub {    # maybe sub call? start looking
  18928.  
  18929.             # We have to check for sub call unless we are sure we
  18930.             # are expecting an operator.  This example from s2p
  18931.             # got mistaken as a q operator in an early version:
  18932.             #   print BODY &q(<<'EOT');
  18933.             if ( $expecting != OPERATOR ) {
  18934.                 scan_identifier();
  18935.             }
  18936.             else {
  18937.             }
  18938.         },
  18939.         '<' => sub {    # angle operator or less than?
  18940.  
  18941.             if ( $expecting != OPERATOR ) {
  18942.                 ( $i, $type ) =
  18943.                   find_angle_operator_termination( $input_line, $i, $rtoken_map,
  18944.                     $expecting );
  18945.  
  18946.             }
  18947.             else {
  18948.             }
  18949.         },
  18950.         '?' => sub {    # ?: conditional or starting pattern?
  18951.  
  18952.             my $is_pattern;
  18953.  
  18954.             if ( $expecting == UNKNOWN ) {
  18955.  
  18956.                 my $msg;
  18957.                 ( $is_pattern, $msg ) =
  18958.                   guess_if_pattern_or_conditional( $i, $rtokens, $rtoken_map );
  18959.  
  18960.                 if ($msg) { write_logfile_entry($msg) }
  18961.             }
  18962.             else { $is_pattern = ( $expecting == TERM ) }
  18963.  
  18964.             if ($is_pattern) {
  18965.                 $in_quote                = 1;
  18966.                 $type                    = 'Q';
  18967.                 $allowed_quote_modifiers = '[cgimosx]';    # TBD:check this
  18968.             }
  18969.             else {
  18970.  
  18971.                 $type_sequence =
  18972.                   increase_nesting_depth( QUESTION_COLON, $i_tok );
  18973.             }
  18974.         },
  18975.         '*' => sub {    # typeglob, or multiply?
  18976.  
  18977.             if ( $expecting == TERM ) {
  18978.                 scan_identifier();
  18979.             }
  18980.             else {
  18981.  
  18982.                 if ( $$rtokens[ $i + 1 ] eq '=' ) {
  18983.                     $tok  = '*=';
  18984.                     $type = $tok;
  18985.                     $i++;
  18986.                 }
  18987.                 elsif ( $$rtokens[ $i + 1 ] eq '*' ) {
  18988.                     $tok  = '**';
  18989.                     $type = $tok;
  18990.                     $i++;
  18991.                     if ( $$rtokens[ $i + 1 ] eq '=' ) {
  18992.                         $tok  = '**=';
  18993.                         $type = $tok;
  18994.                         $i++;
  18995.                     }
  18996.                 }
  18997.             }
  18998.         },
  18999.         '.' => sub {    # what kind of . ?
  19000.  
  19001.             if ( $expecting != OPERATOR ) {
  19002.                 scan_number();
  19003.                 if ( $type eq '.' ) {
  19004.                     error_if_expecting_TERM()
  19005.                       if ( $expecting == TERM );
  19006.                 }
  19007.             }
  19008.             else {
  19009.             }
  19010.         },
  19011.         ':' => sub {
  19012.  
  19013.             # if this is the first nonblank character, call it a label
  19014.             # since perl seems to just swallow it
  19015.             if ( $input_line_number == 1 && $last_nonblank_i == -1 ) {
  19016.                 $type = 'J';
  19017.             }
  19018.  
  19019.             # ATTRS: check for a ':' which introduces an attribute list
  19020.             # (this might eventually get its own token type)
  19021.             elsif ( $statement_type =~ /^sub/ ) {
  19022.                 $type = 'A';
  19023.             }
  19024.  
  19025.             # check for scalar attribute, such as
  19026.             # my $foo : shared = 1;
  19027.             elsif ($is_my_our{$statement_type}
  19028.                 && $current_depth[QUESTION_COLON] == 0 )
  19029.             {
  19030.                 $type = 'A';
  19031.             }
  19032.  
  19033.             # otherwise, it should be part of a ?/: operator
  19034.             else {
  19035.                 $type_sequence =
  19036.                   decrease_nesting_depth( QUESTION_COLON, $i_tok );
  19037.                 if ( $last_nonblank_token eq '?' ) {
  19038.                     warning("Syntax error near ? :\n");
  19039.                 }
  19040.             }
  19041.         },
  19042.         '+' => sub {    # what kind of plus?
  19043.  
  19044.             if ( $expecting == TERM ) {
  19045.                 scan_number();
  19046.  
  19047.                 # unary plus is safest assumption if not a number
  19048.                 if ( !defined($number) ) { $type = 'p'; }
  19049.             }
  19050.             elsif ( $expecting == OPERATOR ) {
  19051.             }
  19052.             else {
  19053.                 if ( $next_type eq 'w' ) { $type = 'p' }
  19054.             }
  19055.         },
  19056.         '@' => sub {
  19057.  
  19058.             error_if_expecting_OPERATOR("Array")
  19059.               if ( $expecting == OPERATOR );
  19060.             scan_identifier();
  19061.         },
  19062.         '%' => sub {    # hash or modulo?
  19063.  
  19064.             # first guess is hash if no following blank
  19065.             if ( $expecting == UNKNOWN ) {
  19066.                 if ( $next_type ne 'b' ) { $expecting = TERM }
  19067.             }
  19068.             if ( $expecting == TERM ) {
  19069.                 scan_identifier();
  19070.             }
  19071.         },
  19072.         '[' => sub {
  19073.             $square_bracket_type[ ++$square_bracket_depth ] =
  19074.               $last_nonblank_token;
  19075.             $type_sequence = increase_nesting_depth( SQUARE_BRACKET, $i_tok );
  19076.  
  19077.             # It may seem odd, but structural square brackets have
  19078.             # type '{' and '}'.  This simplifies the indentation logic.
  19079.             if ( !is_non_structural_brace() ) {
  19080.                 $type = '{';
  19081.             }
  19082.             $square_bracket_structural_type[$square_bracket_depth] = $type;
  19083.         },
  19084.         ']' => sub {
  19085.             $type_sequence = decrease_nesting_depth( SQUARE_BRACKET, $i_tok );
  19086.  
  19087.             if ( $square_bracket_structural_type[$square_bracket_depth] eq '{' )
  19088.             {
  19089.                 $type = '}';
  19090.             }
  19091.             if ( $square_bracket_depth > 0 ) { $square_bracket_depth--; }
  19092.         },
  19093.         '-' => sub {    # what kind of minus?
  19094.  
  19095.             if ( ( $expecting != OPERATOR )
  19096.                 && $is_file_test_operator{$next_tok} )
  19097.             {
  19098.                 $i++;
  19099.                 $tok .= $next_tok;
  19100.                 $type = 'F';
  19101.             }
  19102.             elsif ( $expecting == TERM ) {
  19103.                 scan_number();
  19104.  
  19105.                 # maybe part of bareword token? unary is safest
  19106.                 if ( !defined($number) ) { $type = 'm'; }
  19107.  
  19108.             }
  19109.             elsif ( $expecting == OPERATOR ) {
  19110.             }
  19111.             else {
  19112.  
  19113.                 if ( $next_type eq 'w' ) {
  19114.                     $type = 'm';
  19115.                 }
  19116.             }
  19117.         },
  19118.  
  19119.         '^' => sub {
  19120.  
  19121.             # check for special variables like ${^WARNING_BITS}
  19122.             if ( $expecting == TERM ) {
  19123.  
  19124.                 # FIXME: this should work but will not catch errors
  19125.                 # because we also have to be sure that previous token is
  19126.                 # a type character ($,@,%).
  19127.                 if ( $last_nonblank_token eq '{'
  19128.                     && ( $next_tok =~ /^[A-Za-z_]/ ) )
  19129.                 {
  19130.  
  19131.                     if ( $next_tok eq 'W' ) {
  19132.                         $tokenizer_self->{_saw_perl_dash_w} = 1;
  19133.                     }
  19134.                     $tok  = $tok . $next_tok;
  19135.                     $i    = $i + 1;
  19136.                     $type = 'w';
  19137.                 }
  19138.  
  19139.                 else {
  19140.                     unless ( error_if_expecting_TERM() ) {
  19141.  
  19142.                         # Something like this is valid but strange:
  19143.                         # undef ^I;
  19144.                         complain("The '^' seems unusual here\n");
  19145.                     }
  19146.                 }
  19147.             }
  19148.         },
  19149.  
  19150.         '::' => sub {    # probably a sub call
  19151.             scan_bare_identifier();
  19152.         },
  19153.         '<<' => sub {    # maybe a here-doc?
  19154.             return
  19155.               unless ( $i < $max_token_index )
  19156.               ;          # here-doc not possible if end of line
  19157.  
  19158.             if ( $expecting != OPERATOR ) {
  19159.                 my ($found_target);
  19160.                 ( $found_target, $here_doc_target, $here_quote_character, $i ) =
  19161.                   find_here_doc( $expecting, $i, $rtokens, $rtoken_map );
  19162.  
  19163.                 if ($found_target) {
  19164.                     push @here_target_list,
  19165.                       [ $here_doc_target, $here_quote_character ];
  19166.                     $type = 'h';
  19167.                     if ( length($here_doc_target) > 80 ) {
  19168.                         my $truncated = substr( $here_doc_target, 0, 80 );
  19169.                         complain("Long here-target: '$truncated' ...\n");
  19170.                     }
  19171.                     elsif ( $here_doc_target !~ /^[A-Z_]\w+$/ ) {
  19172.                         complain(
  19173.                             "Unconventional here-target: '$here_doc_target'\n"
  19174.                         );
  19175.                     }
  19176.                 }
  19177.                 elsif ( $expecting == TERM ) {
  19178.  
  19179.                     # shouldn't happen..
  19180.                     warning("Program bug; didn't find here doc target\n");
  19181.                     report_definite_bug();
  19182.                 }
  19183.             }
  19184.             else {
  19185.             }
  19186.         },
  19187.         '->' => sub {
  19188.  
  19189.             # if -> points to a bare word, we must scan for an identifier,
  19190.             # otherwise something like ->y would look like the y operator
  19191.             scan_identifier();
  19192.         },
  19193.  
  19194.         # type = 'pp' for pre-increment, '++' for post-increment
  19195.         '++' => sub {
  19196.             if ( $expecting == TERM ) { $type = 'pp' }
  19197.         },
  19198.  
  19199.         '=>' => sub {
  19200.             if ( $last_nonblank_type eq $tok ) {
  19201.                 complain("Repeated '=>'s \n");
  19202.             }
  19203.         },
  19204.  
  19205.         # type = 'mm' for pre-decrement, '--' for post-decrement
  19206.         '--' => sub {
  19207.  
  19208.             if ( $expecting == TERM ) { $type = 'mm' }
  19209.         },
  19210.  
  19211.         '&&' => sub {
  19212.             error_if_expecting_TERM()
  19213.               if ( $expecting == TERM );
  19214.         },
  19215.  
  19216.         '||' => sub {
  19217.             error_if_expecting_TERM()
  19218.               if ( $expecting == TERM );
  19219.         },
  19220.     };
  19221.  
  19222.     # ------------------------------------------------------------
  19223.     # end hash of code for handling individual token types
  19224.     # ------------------------------------------------------------
  19225.  
  19226.     my %matching_start_token = ( '}' => '{', ']' => '[', ')' => '(' );
  19227.  
  19228.     # These block types terminate statements and do not need a trailing
  19229.     # semicolon
  19230.     # patched for SWITCH/CASE:
  19231.     my %is_zero_continuation_block_type;
  19232.     @_ = qw( } { BEGIN END CHECK INIT AUTOLOAD DESTROY continue ;
  19233.       if elsif else unless while until for foreach switch case given when);
  19234.     @is_zero_continuation_block_type{@_} = (1) x scalar(@_);
  19235.  
  19236.     my %is_not_zero_continuation_block_type;
  19237.     @_ = qw(sort grep map do eval);
  19238.     @is_not_zero_continuation_block_type{@_} = (1) x scalar(@_);
  19239.  
  19240.     my %is_logical_container;
  19241.     @_ = qw(if elsif unless while and or not && !  || for foreach);
  19242.     @is_logical_container{@_} = (1) x scalar(@_);
  19243.  
  19244.     my %is_binary_type;
  19245.     @_ = qw(|| &&);
  19246.     @is_binary_type{@_} = (1) x scalar(@_);
  19247.  
  19248.     # 'L' is token for opening { at hash key
  19249.     my %is_opening_type;
  19250.     @_ = qw" L { ( [ ";
  19251.     @is_opening_type{@_} = (1) x scalar(@_);
  19252.  
  19253.     # 'R' is token for closing } at hash key
  19254.     my %is_closing_type;
  19255.     @_ = qw" R } ) ] ";
  19256.     @is_closing_type{@_} = (1) x scalar(@_);
  19257.  
  19258.     my %is_q_qq_qw_qx_qr_s_y_tr_m;
  19259.     @_ = qw(q qq qw qx qr s y tr m);
  19260.     @is_q_qq_qw_qx_qr_s_y_tr_m{@_} = (1) x scalar(@_);
  19261.  
  19262.     my %is_redo_last_next_goto;
  19263.     @_ = qw(redo last next goto);
  19264.     @is_redo_last_next_goto{@_} = (1) x scalar(@_);
  19265.  
  19266.     my %is_use_require;
  19267.     @_ = qw(use require);
  19268.     @is_use_require{@_} = (1) x scalar(@_);
  19269.  
  19270.     my %is_sub_package;
  19271.     @_ = qw(sub package);
  19272.     @is_sub_package{@_} = (1) x scalar(@_);
  19273.  
  19274.     # This hash holds the hash key in $tokenizer_self for these keywords:
  19275.     my %is_format_END_DATA = (
  19276.         'format'   => '_in_format',
  19277.         '__END__'  => '_in_end',
  19278.         '__DATA__' => '_in_data',
  19279.     );
  19280.  
  19281.     # ref: camel 3 p 147,
  19282.     # but perl may accept undocumented flags
  19283.     my %quote_modifiers = (
  19284.         's'  => '[cegimosx]',
  19285.         'y'  => '[cds]',
  19286.         'tr' => '[cds]',
  19287.         'm'  => '[cgimosx]',
  19288.         'qr' => '[imosx]',
  19289.         'q'  => "",
  19290.         'qq' => "",
  19291.         'qw' => "",
  19292.         'qx' => "",
  19293.     );
  19294.  
  19295.     # table showing how many quoted things to look for after quote operator..
  19296.     # s, y, tr have 2 (pattern and replacement)
  19297.     # others have 1 (pattern only)
  19298.     my %quote_items = (
  19299.         's'  => 2,
  19300.         'y'  => 2,
  19301.         'tr' => 2,
  19302.         'm'  => 1,
  19303.         'qr' => 1,
  19304.         'q'  => 1,
  19305.         'qq' => 1,
  19306.         'qw' => 1,
  19307.         'qx' => 1,
  19308.     );
  19309.  
  19310.     sub tokenize_this_line {
  19311.  
  19312.   # This routine breaks a line of perl code into tokens which are of use in
  19313.   # indentation and reformatting.  One of my goals has been to define tokens
  19314.   # such that a newline may be inserted between any pair of tokens without
  19315.   # changing or invalidating the program. This version comes close to this,
  19316.   # although there are necessarily a few exceptions which must be caught by
  19317.   # the formatter.  Many of these involve the treatment of bare words.
  19318.   #
  19319.   # The tokens and their types are returned in arrays.  See previous
  19320.   # routine for their names.
  19321.   #
  19322.   # See also the array "valid_token_types" in the BEGIN section for an
  19323.   # up-to-date list.
  19324.   #
  19325.   # To simplify things, token types are either a single character, or they
  19326.   # are identical to the tokens themselves.
  19327.   #
  19328.   # As a debugging aid, the -D flag creates a file containing a side-by-side
  19329.   # comparison of the input string and its tokenization for each line of a file.
  19330.   # This is an invaluable debugging aid.
  19331.   #
  19332.   # In addition to tokens, and some associated quantities, the tokenizer
  19333.   # also returns flags indication any special line types.  These include
  19334.   # quotes, here_docs, formats.
  19335.   #
  19336.   # -----------------------------------------------------------------------
  19337.   #
  19338.   # How to add NEW_TOKENS:
  19339.   #
  19340.   # New token types will undoubtedly be needed in the future both to keep up
  19341.   # with changes in perl and to help adapt the tokenizer to other applications.
  19342.   #
  19343.   # Here are some notes on the minimal steps.  I wrote these notes while
  19344.   # adding the 'v' token type for v-strings, which are things like version
  19345.   # numbers 5.6.0, and ip addresses, and will use that as an example.  ( You
  19346.   # can use your editor to search for the string "NEW_TOKENS" to find the
  19347.   # appropriate sections to change):
  19348.   #
  19349.   # *. Try to talk somebody else into doing it!  If not, ..
  19350.   #
  19351.   # *. Make a backup of your current version in case things don't work out!
  19352.   #
  19353.   # *. Think of a new, unused character for the token type, and add to
  19354.   # the array @valid_token_types in the BEGIN section of this package.
  19355.   # For example, I used 'v' for v-strings.
  19356.   #
  19357.   # *. Implement coding to recognize the $type of the token in this routine.
  19358.   # This is the hardest part, and is best done by immitating or modifying
  19359.   # some of the existing coding.  For example, to recognize v-strings, I
  19360.   # patched 'sub scan_bare_identifier' to recognize v-strings beginning with
  19361.   # 'v' and 'sub scan_number' to recognize v-strings without the leading 'v'.
  19362.   #
  19363.   # *. Update sub operator_expected.  This update is critically important but
  19364.   # the coding is trivial.  Look at the comments in that routine for help.
  19365.   # For v-strings, which should behave like numbers, I just added 'v' to the
  19366.   # regex used to handle numbers and strings (types 'n' and 'Q').
  19367.   #
  19368.   # *. Implement a 'bond strength' rule in sub set_bond_strengths in
  19369.   # Perl::Tidy::Formatter for breaking lines around this token type.  You can
  19370.   # skip this step and take the default at first, then adjust later to get
  19371.   # desired results.  For adding type 'v', I looked at sub bond_strength and
  19372.   # saw that number type 'n' was using default strengths, so I didn't do
  19373.   # anything.  I may tune it up someday if I don't like the way line
  19374.   # breaks with v-strings look.
  19375.   #
  19376.   # *. Implement a 'whitespace' rule in sub set_white_space_flag in
  19377.   # Perl::Tidy::Formatter.  For adding type 'v', I looked at this routine
  19378.   # and saw that type 'n' used spaces on both sides, so I just added 'v'
  19379.   # to the array @spaces_both_sides.
  19380.   #
  19381.   # *. Update HtmlWriter package so that users can colorize the token as
  19382.   # desired.  This is quite easy; see comments identified by 'NEW_TOKENS' in
  19383.   # that package.  For v-strings, I initially chose to use a default color
  19384.   # equal to the default for numbers, but it might be nice to change that
  19385.   # eventually.
  19386.   #
  19387.   # *. Update comments in Perl::Tidy::Tokenizer::dump_token_types.
  19388.   #
  19389.   # *. Run lots and lots of debug tests.  Start with special files designed
  19390.   # to test the new token type.  Run with the -D flag to create a .DEBUG
  19391.   # file which shows the tokenization.  When these work ok, test as many old
  19392.   # scripts as possible.  Start with all of the '.t' files in the 'test'
  19393.   # directory of the distribution file.  Compare .tdy output with previous
  19394.   # version and updated version to see the differences.  Then include as
  19395.   # many more files as possible. My own technique has been to collect a huge
  19396.   # number of perl scripts (thousands!) into one directory and run perltidy
  19397.   # *, then run diff between the output of the previous version and the
  19398.   # current version.
  19399.   #
  19400.   # -----------------------------------------------------------------------
  19401.  
  19402.         my $line_of_tokens = shift;
  19403.         my ($untrimmed_input_line) = $line_of_tokens->{_line_text};
  19404.  
  19405.         # patch while coding change is underway
  19406.         # make callers private data to allow access
  19407.         # $tokenizer_self = $caller_tokenizer_self;
  19408.  
  19409.         # extract line number for use in error messages
  19410.         $input_line_number = $line_of_tokens->{_line_number};
  19411.  
  19412.         # check for pod documentation
  19413.         if ( ( $untrimmed_input_line =~ /^=[A-Za-z_]/ ) ) {
  19414.  
  19415.             # must not be in multi-line quote
  19416.             # and must not be in an eqn
  19417.             if ( !$in_quote and ( operator_expected( 'b', '=', 'b' ) == TERM ) )
  19418.             {
  19419.                 $tokenizer_self->{_in_pod} = 1;
  19420.                 return;
  19421.             }
  19422.         }
  19423.  
  19424.         $input_line = $untrimmed_input_line;
  19425.  
  19426.         chomp $input_line;
  19427.  
  19428.         # trim start of this line unless we are continuing a quoted line
  19429.         # do not trim end because we might end in a quote (test: deken4.pl)
  19430.         # Perl::Tidy::Formatter will delete needless trailing blanks
  19431.         unless ( $in_quote && ( $quote_type eq 'Q' ) ) {
  19432.             $input_line =~ s/^\s*//;    # trim left end
  19433.         }
  19434.  
  19435.         # initialize for the main loop
  19436.         my @output_token_list     = ();    # stack of output token indexes
  19437.         my @output_token_type     = ();    # token types
  19438.         my @output_block_type     = ();    # types of code block
  19439.         my @output_container_type = ();    # paren types, such as if, elsif, ..
  19440.         my @output_type_sequence  = ();    # nesting sequential number
  19441.  
  19442.         $tok             = $last_nonblank_token;
  19443.         $type            = $last_nonblank_type;
  19444.         $prototype       = $last_nonblank_prototype;
  19445.         $last_nonblank_i = -1;
  19446.         $block_type      = $last_nonblank_block_type;
  19447.         $container_type  = $last_nonblank_container_type;
  19448.         $type_sequence   = $last_nonblank_type_sequence;
  19449.         @here_target_list = ();            # list of here-doc target strings
  19450.  
  19451.         $peeked_ahead = 0;
  19452.  
  19453.         # tokenization is done in two stages..
  19454.         # stage 1 is a very simple pre-tokenization
  19455.         my $max_tokens_wanted = 0; # this signals pre_tokenize to get all tokens
  19456.  
  19457.         # a little optimization for a full-line comment
  19458.         if ( !$in_quote && ( $input_line =~ /^#/ ) ) {
  19459.             $max_tokens_wanted = 1    # no use tokenizing a comment
  19460.         }
  19461.  
  19462.         # start by breaking the line into pre-tokens
  19463.         ( $rpretokens, $rpretoken_map, $rpretoken_type ) =
  19464.           pre_tokenize( $input_line, $max_tokens_wanted );
  19465.  
  19466.         $max_token_index = scalar(@$rpretokens) - 1;
  19467.         push ( @$rpretokens, ' ', ' ', ' ' )
  19468.           ;                           # extra whitespace simplifies logic
  19469.         push ( @$rpretoken_map,  0,   0,   0 );     # shouldn't be referenced
  19470.         push ( @$rpretoken_type, 'b', 'b', 'b' );
  19471.  
  19472.         # temporary copies while coding change is underway
  19473.         ( $rtokens, $rtoken_map, $rtoken_type ) =
  19474.           ( $rpretokens, $rpretoken_map, $rpretoken_type );
  19475.  
  19476.         # initialize for main loop
  19477.         for $i ( 0 .. $max_token_index + 3 ) {
  19478.             $output_token_type[$i]     = "";
  19479.             $output_block_type[$i]     = "";
  19480.             $output_container_type[$i] = "";
  19481.             $output_type_sequence[$i]  = "";
  19482.         }
  19483.         $i     = -1;
  19484.         $i_tok = -1;
  19485.  
  19486.         # ------------------------------------------------------------
  19487.         # begin main tokenization loop
  19488.         # ------------------------------------------------------------
  19489.  
  19490.         # we are looking at each pre-token of one line and combining them
  19491.         # into tokens
  19492.         while ( ++$i <= $max_token_index ) {
  19493.  
  19494.             if ($in_quote) {    # continue looking for end of a quote
  19495.                 $type = $quote_type;
  19496.  
  19497.                 unless (@output_token_list) {  # initialize if continuation line
  19498.                     push ( @output_token_list, $i );
  19499.                     $output_token_type[$i] = $type;
  19500.  
  19501.                 }
  19502.                 $tok = $quote_character unless ( $quote_character =~ /^\s*$/ );
  19503.  
  19504.                 # scan for the end of the quote or pattern
  19505.                 ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth ) =
  19506.                   do_quote( $i, $in_quote, $quote_character, $quote_pos,
  19507.                     $quote_depth, $rtokens, $rtoken_map );
  19508.  
  19509.                 # all done if we didn't find it
  19510.                 last if ($in_quote);
  19511.  
  19512.                 # re-initialize for next search
  19513.                 $quote_character = '';
  19514.                 $quote_pos       = 0;
  19515.                 $quote_type      = 'Q';
  19516.                 last if ( ++$i > $max_token_index );
  19517.  
  19518.                 # look for any modifiers
  19519.                 if ($allowed_quote_modifiers) {
  19520.  
  19521.                     # check for exact quote modifiers
  19522.                     if ( $$rtokens[$i] =~ /^[A-Za-z_]/ ) {
  19523.                         my $str = $$rtokens[$i];
  19524.                         while ( $str =~ /\G$allowed_quote_modifiers/gc ) { }
  19525.  
  19526.                         if ( defined( pos($str) ) ) {
  19527.  
  19528.                             # matched
  19529.                             if ( pos($str) == length($str) ) {
  19530.                                 last if ( ++$i > $max_token_index );
  19531.                             }
  19532.  
  19533.                             # Looks like a joined quote modifier
  19534.                             # and keyword, maybe something like
  19535.                             # s/xxx/yyy/gefor @k=...
  19536.                             # Example is "galgen.pl".  Would have to split
  19537.                             # the word and insert a new token in the
  19538.                             # pre-token list.  This is so rare that I haven't
  19539.                             # done it.  Will just issue a warning citation.
  19540.  
  19541.                             # This error might also be triggered if my quote
  19542.                             # modifier characters are incomplete
  19543.                             else {
  19544.                                 warning(<<EOM);
  19545.  
  19546. Partial match to quote modifier $allowed_quote_modifiers at word: '$str'
  19547. Please put a space between quote modifiers and trailing keywords.
  19548. EOM
  19549.  
  19550.                            # print "token $$rtokens[$i]\n";
  19551.                            # my $num = length($str) - pos($str);
  19552.                            # $$rtokens[$i]=substr($$rtokens[$i],pos($str),$num);
  19553.                            # print "continuing with new token $$rtokens[$i]\n";
  19554.  
  19555.                                 # skipping past this token does least damage
  19556.                                 last if ( ++$i > $max_token_index );
  19557.                             }
  19558.                         }
  19559.                         else {
  19560.  
  19561.                             # example file: rokicki4.pl
  19562.                             # This error might also be triggered if my quote
  19563.                             # modifier characters are incomplete
  19564.                             write_logfile_entry(
  19565. "Note: found word $str at quote modifier location\n"
  19566.                             );
  19567.                         }
  19568.                     }
  19569.  
  19570.                     # re-initialize
  19571.                     $allowed_quote_modifiers = "";
  19572.                 }
  19573.             }
  19574.  
  19575.             unless ( $tok =~ /^\s*$/ ) {
  19576.  
  19577.                 # try to catch some common errors
  19578.                 if ( ( $type eq 'n' ) && ( $tok ne '0' ) ) {
  19579.  
  19580.                     if ( $last_nonblank_token eq 'eq' ) {
  19581.                         complain("Should 'eq' be '==' here ?\n");
  19582.                     }
  19583.                     elsif ( $last_nonblank_token eq 'ne' ) {
  19584.                         complain("Should 'ne' be '!=' here ?\n");
  19585.                     }
  19586.                 }
  19587.  
  19588.                 $last_last_nonblank_token          = $last_nonblank_token;
  19589.                 $last_last_nonblank_type           = $last_nonblank_type;
  19590.                 $last_last_nonblank_block_type     = $last_nonblank_block_type;
  19591.                 $last_last_nonblank_container_type =
  19592.                   $last_nonblank_container_type;
  19593.                 $last_last_nonblank_type_sequence =
  19594.                   $last_nonblank_type_sequence;
  19595.                 $last_nonblank_token          = $tok;
  19596.                 $last_nonblank_type           = $type;
  19597.                 $last_nonblank_prototype      = $prototype;
  19598.                 $last_nonblank_block_type     = $block_type;
  19599.                 $last_nonblank_container_type = $container_type;
  19600.                 $last_nonblank_type_sequence  = $type_sequence;
  19601.                 $last_nonblank_i              = $i_tok;
  19602.             }
  19603.  
  19604.             # store previous token type
  19605.             if ( $i_tok >= 0 ) {
  19606.                 $output_token_type[$i_tok]     = $type;
  19607.                 $output_block_type[$i_tok]     = $block_type;
  19608.                 $output_container_type[$i_tok] = $container_type;
  19609.                 $output_type_sequence[$i_tok]  = $type_sequence;
  19610.             }
  19611.             my $pre_tok  = $$rtokens[$i];        # get the next pre-token
  19612.             my $pre_type = $$rtoken_type[$i];    # and type
  19613.             $tok  = $pre_tok;
  19614.             $type = $pre_type;                   # to be modified as necessary
  19615.             $block_type = "";    # blank for all tokens except code block braces
  19616.             $container_type = "";    # blank for all tokens except some parens
  19617.             $type_sequence  = "";    # blank for all tokens except ?/:
  19618.             $prototype = "";    # blank for all tokens except user defined subs
  19619.             $i_tok     = $i;
  19620.  
  19621.             # this pre-token will start an output token
  19622.             push ( @output_token_list, $i_tok );
  19623.  
  19624.             # continue gathering identifier if necessary
  19625.             # but do not start on blanks and comments
  19626.             if ( $id_scan_state && $pre_type !~ /[b#]/ ) {
  19627.  
  19628.                 if ( $id_scan_state =~ /^(sub|package)/ ) {
  19629.                     scan_id();
  19630.                 }
  19631.                 else {
  19632.                     scan_identifier();
  19633.                 }
  19634.  
  19635.                 last if ($id_scan_state);
  19636.                 next if ( ( $i > 0 ) || $type );
  19637.  
  19638.                 # didn't find any token; start over
  19639.                 $type = $pre_type;
  19640.                 $tok  = $pre_tok;
  19641.             }
  19642.  
  19643.             # handle whitespace tokens..
  19644.             next if ( $type eq 'b' );
  19645.             my $prev_tok  = $i > 0 ? $$rtokens[ $i - 1 ]     : ' ';
  19646.             my $prev_type = $i > 0 ? $$rtoken_type[ $i - 1 ] : 'b';
  19647.  
  19648.             # Build larger tokens where possible, since we are not in a quote.
  19649.             #
  19650.             # First try to assemble digraphs.  The following tokens are
  19651.             # excluded and handled specially:
  19652.             # '/=' is excluded because the / might start a pattern.
  19653.             # 'x=' is excluded since it might be $x=, with $ on previous line
  19654.             # '**' and *= might be typeglobs of punctuation variables
  19655.             # I have allowed tokens starting with <, such as <=,
  19656.             # because I don't think these could be valid angle operators.
  19657.             # test file: storrs4.pl
  19658.             my $test_tok = $tok . $$rtokens[ $i + 1 ];
  19659.  
  19660.             if (
  19661.                 $is_digraph{$test_tok}
  19662.                 && ( $test_tok ne '/=' )    # might be pattern
  19663.                 && ( $test_tok ne 'x=' )    # might be $x
  19664.                 && ( $test_tok ne '**' )    # typeglob?
  19665.                 && ( $test_tok ne '*=' )    # typeglob?
  19666.               )
  19667.             {
  19668.                 $tok = $test_tok;
  19669.                 $i++;
  19670.  
  19671.                 # Now try to assemble trigraphs.  Note that all possible
  19672.                 # perl trigraphs can be constructed by appending a character
  19673.                 # to a digraph.
  19674.                 $test_tok = $tok . $$rtokens[ $i + 1 ];
  19675.  
  19676.                 if ( $is_trigraph{$test_tok} ) {
  19677.                     $tok = $test_tok;
  19678.                     $i++;
  19679.                 }
  19680.             }
  19681.             $type      = $tok;
  19682.             $next_tok  = $$rtokens[ $i + 1 ];
  19683.             $next_type = $$rtoken_type[ $i + 1 ];
  19684.  
  19685.             TOKENIZER_DEBUG_FLAG_TOKENIZE && do {
  19686.                 local $" = ')(';
  19687.                 my @debug_list = (
  19688.                     $last_nonblank_token,      $tok,
  19689.                     $next_tok,                 $brace_depth,
  19690.                     $brace_type[$brace_depth], $paren_depth,
  19691.                     $paren_type[$paren_depth]
  19692.                 );
  19693.                 print "TOKENIZE:(@debug_list)\n";
  19694.             };
  19695.  
  19696.             ###############################################################
  19697.             # We have the next token, $tok.
  19698.             # Now we have to examine this token and decide what it is
  19699.             # and define its $type
  19700.             #
  19701.             # section 1: bare words
  19702.             ###############################################################
  19703.  
  19704.             if ( $pre_type eq 'w' ) {
  19705.                 $expecting = operator_expected( $prev_type, $tok, $next_type );
  19706.                 my ( $next_nonblank_token, $i_next ) =
  19707.                   find_next_nonblank_token( $i, $rtokens );
  19708.  
  19709.                 # quote a word followed by => operator
  19710.                 if ( $next_nonblank_token eq '=' ) {
  19711.  
  19712.                     if ( $$rtokens[ $i_next + 1 ] eq '>' ) {
  19713.                         if ( $is_constant{$current_package}{$tok} ) {
  19714.                             $type = 'C';
  19715.                         }
  19716.                         elsif ( $is_user_function{$current_package}{$tok} ) {
  19717.                             $type      = 'U';
  19718.                             $prototype =
  19719.                               $user_function_prototype{$current_package}{$tok};
  19720.                         }
  19721.                         elsif ( $tok =~ /^v\d+$/ ) {
  19722.                             $type = 'v';
  19723.                             unless ($saw_v_string) { report_v_string($tok) }
  19724.                         }
  19725.                         else { $type = 'w' }
  19726.  
  19727.                         next;
  19728.                     }
  19729.                 }
  19730.  
  19731.                 # quote a bare word within braces..like xxx->{s}; note that we
  19732.                 # must be sure this is not a structural brace, to avoid
  19733.                 # mistaking {s} in the following for a quoted bare word:
  19734.                 #     for(@[){s}bla}BLA}
  19735.                 if (   ( $last_nonblank_type eq 'L' )
  19736.                     && ( $next_nonblank_token eq '}' ) )
  19737.                 {
  19738.                     $type = 'w';
  19739.                     next;
  19740.                 }
  19741.  
  19742.                 # a bare word immediately followed by :: is not a keyword;
  19743.                 # use $tok_kw when testing for keywords to avoid a mistake
  19744.                 my $tok_kw = $tok;
  19745.                 if ( $$rtokens[ $i + 1 ] eq ':' && $$rtokens[ $i + 2 ] eq ':' )
  19746.                 {
  19747.                     $tok_kw .= '::';
  19748.                 }
  19749.  
  19750.                 # handle operator x (now we know it isn't $x=)
  19751.                 if ( ( $tok =~ /^x\d*$/ ) && ( $expecting == OPERATOR ) ) {
  19752.                     if ( $tok eq 'x' ) {
  19753.  
  19754.                         if ( $$rtokens[ $i + 1 ] eq '=' ) {    # x=
  19755.                             $tok  = 'x=';
  19756.                             $type = $tok;
  19757.                             $i++;
  19758.                         }
  19759.                         else {
  19760.                             $type = 'x';
  19761.                         }
  19762.                     }
  19763.  
  19764.                     # FIXME: Patch: mark something like x4 as an integer for now
  19765.                     # It gets fixed downstream.  This is easier than
  19766.                     # splitting the pretoken.
  19767.                     else {
  19768.                         $type = 'n';
  19769.                     }
  19770.                 }
  19771.  
  19772.                 elsif ( ( $tok eq 'strict' )
  19773.                     and ( $last_nonblank_token eq 'use' ) )
  19774.                 {
  19775.                     $tokenizer_self->{_saw_use_strict} = 1;
  19776.                     scan_bare_identifier();
  19777.                 }
  19778.  
  19779.                 elsif ( ( $tok eq 'warnings' )
  19780.                     and ( $last_nonblank_token eq 'use' ) )
  19781.                 {
  19782.                     $tokenizer_self->{_saw_perl_dash_w} = 1;
  19783.  
  19784.                     # scan as identifier, so that we pick up something like:
  19785.                     # use warnings::register
  19786.                     scan_bare_identifier();
  19787.                 }
  19788.  
  19789.                 elsif (
  19790.                        $tok eq 'AutoLoader'
  19791.                     && $tokenizer_self->{_look_for_autoloader}
  19792.                     && (
  19793.                         $last_nonblank_token eq 'use'
  19794.  
  19795.                         # these regexes are from AutoSplit.pm, which we want
  19796.                         # to mimic
  19797.                         || $input_line =~ /^\s*(use|require)\s+AutoLoader\b/
  19798.                         || $input_line =~ /\bISA\s*=.*\bAutoLoader\b/
  19799.                     )
  19800.                   )
  19801.                 {
  19802.                     write_logfile_entry("AutoLoader seen, -nlal deactivates\n");
  19803.                     $tokenizer_self->{_saw_autoloader}      = 1;
  19804.                     $tokenizer_self->{_look_for_autoloader} = 0;
  19805.                     scan_bare_identifier();
  19806.                 }
  19807.  
  19808.                 elsif (
  19809.                        $tok eq 'SelfLoader'
  19810.                     && $tokenizer_self->{_look_for_selfloader}
  19811.                     && (   $last_nonblank_token eq 'use'
  19812.                         || $input_line =~ /^\s*(use|require)\s+SelfLoader\b/
  19813.                         || $input_line =~ /\bISA\s*=.*\bSelfLoader\b/ )
  19814.                   )
  19815.                 {
  19816.                     write_logfile_entry("SelfLoader seen, -nlsl deactivates\n");
  19817.                     $tokenizer_self->{_saw_selfloader}      = 1;
  19818.                     $tokenizer_self->{_look_for_selfloader} = 0;
  19819.                     scan_bare_identifier();
  19820.                 }
  19821.  
  19822.                 elsif ( ( $tok eq 'constant' )
  19823.                     and ( $last_nonblank_token eq 'use' ) )
  19824.                 {
  19825.                     scan_bare_identifier();
  19826.                     my ( $next_nonblank_token, $i_next ) =
  19827.                       find_next_nonblank_token( $i, $rtokens );
  19828.  
  19829.                     if ($next_nonblank_token) {
  19830.  
  19831.                         if ( $is_keyword{$next_nonblank_token} ) {
  19832.                             warning(
  19833. "Attempting to define constant '$next_nonblank_token' which is a perl keyword\n"
  19834.                             );
  19835.                         }
  19836.  
  19837.                         # FIXME: could check for error in which next token is
  19838.                         # not a word (number, punctuation, ..)
  19839.                         else {
  19840.                             $is_constant{$current_package}
  19841.                               {$next_nonblank_token} = 1;
  19842.                         }
  19843.                     }
  19844.                 }
  19845.  
  19846.                 # various quote operators
  19847.                 elsif ( $is_q_qq_qw_qx_qr_s_y_tr_m{$tok} ) {
  19848.                     if ( $expecting == OPERATOR ) {
  19849.  
  19850.                         # patch for paren-less for/foreach glitch, part 1
  19851.                         # perl will accept this construct as valid:
  19852.                         #
  19853.                         #    foreach my $key qw\Uno Due Tres Quadro\ {
  19854.                         #        print "Set $key\n";
  19855.                         #    }
  19856.                         unless ( $tok eq 'qw' && $is_for_foreach{$want_paren} )
  19857.                         {
  19858.                             error_if_expecting_OPERATOR();
  19859.                         }
  19860.                     }
  19861.                     $in_quote                = $quote_items{$tok};
  19862.                     $allowed_quote_modifiers = $quote_modifiers{$tok};
  19863.  
  19864.                    # All quote types are 'Q' except possibly qw quotes.
  19865.                    # qw quotes are special in that they may generally be trimmed
  19866.                    # of leading and trailing whitespace.  So they are given a
  19867.                    # separate type, 'q', unless requested otherwise.
  19868.                     $type =
  19869.                       ( $tok eq 'qw' && $tokenizer_self->{_trim_qw} )
  19870.                       ? 'q'
  19871.                       : 'Q';
  19872.                     $quote_type = $type;
  19873.                 }
  19874.  
  19875.                 # check for a statement label
  19876.                 elsif (( $next_nonblank_token eq ':' )
  19877.                     && ( $$rtokens[ $i_next + 1 ] ne ':' )
  19878.                     && label_ok() )
  19879.                 {
  19880.                     if ( $tok !~ /A-Z/ ) {
  19881.                         push @lower_case_labels_at, $input_line_number;
  19882.                     }
  19883.                     $type = 'J';
  19884.                     $tok .= ':';
  19885.                     $i = $i_next;
  19886.                     next;
  19887.                 }
  19888.  
  19889.                 #      'sub' || 'package'
  19890.                 elsif ( $is_sub_package{$tok_kw} ) {
  19891.                     error_if_expecting_OPERATOR()
  19892.                       if ( $expecting == OPERATOR );
  19893.                     scan_id();
  19894.                 }
  19895.  
  19896.                 # Note on token types for format, __DATA__, __END__:
  19897.                 # It simplifies things to give these type ';', so that when we
  19898.                 # start rescanning we will be expecting a token of type TERM.
  19899.                 # We will switch to type 'k' before outputting the tokens.
  19900.                 elsif ( $is_format_END_DATA{$tok_kw} ) {
  19901.                     $type = ';';    # make tokenizer look for TERM next
  19902.                     $tokenizer_self->{ $is_format_END_DATA{$tok_kw} } = 1;
  19903.                     last;
  19904.                 }
  19905.  
  19906.                 elsif ( $is_keyword{$tok_kw} ) {
  19907.                     $type = 'k';
  19908.  
  19909.                     # Since for and foreach may not be followed immediately
  19910.                     # by an opening paren, we have to remember which keyword
  19911.                     # is associated with the next '('
  19912.                     if ( $is_for_foreach{$tok} ) {
  19913.                         if ( new_statement_ok() ) {
  19914.                             $want_paren = $tok;
  19915.                         }
  19916.                     }
  19917.  
  19918.                     # recognize 'use' statements, which are special
  19919.                     elsif ( $is_use_require{$tok} ) {
  19920.                         $statement_type = $tok;
  19921.                         error_if_expecting_OPERATOR()
  19922.                           if ( $expecting == OPERATOR );
  19923.                     }
  19924.  
  19925.                     # remember my and our to check for trailing ": shared"
  19926.                     elsif ( $is_my_our{$tok} ) {
  19927.                         $statement_type = $tok;
  19928.                     }
  19929.  
  19930.                     # Check for misplaced 'elsif' and 'else', but allow isolated
  19931.                     # else or elsif blocks to be formatted.  This is indicated
  19932.                     # by a last noblank token of ';'
  19933.                     elsif ( $tok eq 'elsif' ) {
  19934.                         if (   $last_nonblank_token ne ';'
  19935.                             && $last_nonblank_block_type !~
  19936.                             /^(if|elsif|unless)$/ )
  19937.                         {
  19938.                             warning(
  19939. "expecting '$tok' to follow one of 'if|elsif|unless'\n"
  19940.                             );
  19941.                         }
  19942.                     }
  19943.                     elsif ( $tok eq 'else' ) {
  19944.  
  19945.                         # patched for SWITCH/CASE
  19946.                         if (   $last_nonblank_token ne ';'
  19947.                             && $last_nonblank_block_type !~
  19948.                             /^(if|elsif|unless|case|when)$/ )
  19949.                         {
  19950.                             warning(
  19951. "expecting '$tok' to follow one of 'if|elsif|unless|case|when'\n"
  19952.                             );
  19953.                         }
  19954.                     }
  19955.                     elsif ( $tok eq 'continue' ) {
  19956.                         if (   $last_nonblank_token ne ';'
  19957.                             && $last_nonblank_block_type !~
  19958.                             /^(\{|\}|;|while|until|for|foreach)$/ )
  19959.                         {
  19960.  
  19961.                             # note: ';' '{' and '}' in list above
  19962.                             # because continues can follow bare blocks
  19963.                             warning("'$tok' should follow a block\n");
  19964.                         }
  19965.                     }
  19966.  
  19967.                     # patch for SWITCH/CASE if 'case' and 'when are
  19968.                     # treated as keywords.
  19969.                     elsif ( $tok eq 'when' || $tok eq 'case' ) {
  19970.                         $statement_type = $tok;    # next '{' is block
  19971.                     }
  19972.                 }
  19973.  
  19974.                 # check for inline label following
  19975.                 #         /^(redo|last|next|goto)$/
  19976.                 elsif (( $last_nonblank_type eq 'k' )
  19977.                     && ( $is_redo_last_next_goto{$last_nonblank_token} ) )
  19978.                 {
  19979.                     $type = 'j';
  19980.                     next;
  19981.                 }
  19982.  
  19983.                 # something else --
  19984.                 else {
  19985.  
  19986.                     scan_bare_identifier();
  19987.                     if ( $type eq 'w' ) {
  19988.                         error_if_expecting_OPERATOR("bareword")
  19989.                           if ( $expecting == OPERATOR );
  19990.  
  19991.                         # mark bare words immediately followed by a paren as
  19992.                         # functions
  19993.                         $next_tok = $$rtokens[ $i + 1 ];
  19994.                         if ( $next_tok eq '(' ) {
  19995.                             $type = 'U';
  19996.                         }
  19997.  
  19998.                         # mark bare words following a file test operator as
  19999.                         # something that will expect an operator next.
  20000.                         # patch 072901: unless followed immediately by a paren,
  20001.                         # in which case it must be a function call (pid.t)
  20002.                         if ( $last_nonblank_type eq 'F' && $next_tok ne '(' ) {
  20003.                             $type = 'C';
  20004.                         }
  20005.  
  20006.                         # patch for SWITCH/CASE if 'case' and 'when are
  20007.                         # not treated as keywords:
  20008.                         if (
  20009.                             (
  20010.                                    $tok                      eq 'case'
  20011.                                 && $brace_type[$brace_depth] eq 'switch'
  20012.                             )
  20013.                             || (   $tok eq 'when'
  20014.                                 && $brace_type[$brace_depth] eq 'given' )
  20015.                           )
  20016.                         {
  20017.                             $statement_type = $tok;    # next '{' is block
  20018.                             $type = 'k';    # for keyword syntax coloring
  20019.                         }
  20020.  
  20021.                         # patch for SWITCH/CASE if switch and given not keywords
  20022.                         # Switch is not a perl 5 keyword, but we will gamble
  20023.                         # and mark switch followed by paren as a keyword.  This
  20024.                         # is only necessary to get html syntax coloring nice,
  20025.                         # and does not commit this as being a switch/case.
  20026.                         if ( $next_nonblank_token eq '('
  20027.                             && ( $tok eq 'switch' || $tok eq 'given' ) )
  20028.                         {
  20029.                             $type = 'k';    # for keyword syntax coloring
  20030.                         }
  20031.                     }
  20032.                 }
  20033.             }
  20034.  
  20035.             ###############################################################
  20036.             # section 2: strings of digits
  20037.             ###############################################################
  20038.             elsif ( $pre_type eq 'd' ) {
  20039.                 $expecting = operator_expected( $prev_type, $tok, $next_type );
  20040.                 error_if_expecting_OPERATOR("Number")
  20041.                   if ( $expecting == OPERATOR );
  20042.                 scan_number();
  20043.                 if ( !defined($number) ) {
  20044.  
  20045.                     # shouldn't happen - we should always get a number
  20046.                     warning("non-number beginning with digit--program bug\n");
  20047.                     report_definite_bug();
  20048.                 }
  20049.             }
  20050.  
  20051.             ###############################################################
  20052.             # section 3: all other tokens
  20053.             ###############################################################
  20054.  
  20055.             else {
  20056.                 last if ( $tok eq '#' );
  20057.                 my $code = $tokenization_code->{$tok};
  20058.                 if ($code) {
  20059.                     $expecting =
  20060.                       operator_expected( $prev_type, $tok, $next_type );
  20061.                     $code->();
  20062.                     redo if $in_quote;
  20063.                 }
  20064.             }
  20065.         }
  20066.  
  20067.         # -----------------------------
  20068.         # end of main tokenization loop
  20069.         # -----------------------------
  20070.  
  20071.         if ( $i_tok >= 0 ) {
  20072.             $output_token_type[$i_tok]     = $type;
  20073.             $output_block_type[$i_tok]     = $block_type;
  20074.             $output_container_type[$i_tok] = $container_type;
  20075.             $output_type_sequence[$i_tok]  = $type_sequence;
  20076.         }
  20077.  
  20078.         unless ( ( $type eq 'b' ) || ( $type eq '#' ) ) {
  20079.             $last_last_nonblank_token          = $last_nonblank_token;
  20080.             $last_last_nonblank_type           = $last_nonblank_type;
  20081.             $last_last_nonblank_block_type     = $last_nonblank_block_type;
  20082.             $last_last_nonblank_container_type = $last_nonblank_container_type;
  20083.             $last_last_nonblank_type_sequence  = $last_nonblank_type_sequence;
  20084.             $last_nonblank_token               = $tok;
  20085.             $last_nonblank_type                = $type;
  20086.             $last_nonblank_block_type          = $block_type;
  20087.             $last_nonblank_container_type      = $container_type;
  20088.             $last_nonblank_type_sequence       = $type_sequence;
  20089.             $last_nonblank_prototype           = $prototype;
  20090.         }
  20091.  
  20092.         # reset indentation level if necessary at a sub or package
  20093.         # in an attempt to recover from a nesting error
  20094.         if ( $level_in_tokenizer < 0 ) {
  20095.             if ( $input_line =~ /^\s*(sub|package)\s+(\w+)/ ) {
  20096.                 reset_indentation_level(0);
  20097.                 brace_warning("resetting level to 0 at $1 $2\n");
  20098.             }
  20099.         }
  20100.  
  20101.         # all done tokenizing this line ...
  20102.         # now prepare the final list of tokens and types
  20103.  
  20104.         my @token_type     = ();   # stack of output token types
  20105.         my @block_type     = ();   # stack of output code block types
  20106.         my @container_type = ();   # stack of output code container types
  20107.         my @type_sequence  = ();   # stack of output type sequence numbers
  20108.         my @tokens         = ();   # output tokens
  20109.         my @levels         = ();   # structural brace levels of output tokens
  20110.         my @slevels        = ();   # secondary nesting levels of output tokens
  20111.         my @nesting_tokens = ();   # string of tokens leading to this depth
  20112.         my @nesting_types  = ();   # string of token types leading to this depth
  20113.         my @nesting_blocks = ();   # string of block types leading to this depth
  20114.         my @nesting_lists  = ();   # string of list types leading to this depth
  20115.         my @ci_string = ();  # string needed to compute continuation indentation
  20116.         my @container_environment = ();    # BLOCK or LIST
  20117.         my $container_environment = '';
  20118.         my $im                    = -1;    # previous $i value
  20119.         my $num;
  20120.         my $ci_string_sum = ( $_ = $ci_string_in_tokenizer ) =~ tr/1/0/;
  20121.  
  20122. # =head1 Computing Token Indentation
  20123. #
  20124. #     The final section of the tokenizer forms tokens and also computes
  20125. #     parameters needed to find indentation.  It is much easier to do it
  20126. #     in the tokenizer than elsewhere.  Here is a brief description of how
  20127. #     indentation is computed.  Perl::Tidy computes indentation as the sum
  20128. #     of 2 terms:
  20129. #
  20130. #     (1) structural indentation, such as if/else/elsif blocks
  20131. #     (2) continuation indentation, such as long parameter call lists.
  20132. #
  20133. #     These are occasionally called primary and secondary indentation.
  20134. #
  20135. #     Structural indentation is introduced by tokens of type '{', although
  20136. #     the actual tokens might be '{', '(', or '['.  Structural indentation
  20137. #     is of two types: BLOCK and non-BLOCK.  Default structural indentation
  20138. #     is 4 characters if the standard indentation scheme is used.
  20139. #
  20140. #     Continuation indentation is introduced whenever a line at BLOCK level
  20141. #     is broken before its termination.  Default continuation indentation
  20142. #     is 2 characters in the standard indentation scheme.
  20143. #
  20144. #     Both types of indentation may be nested arbitrarily deep and
  20145. #     interlaced.  The distinction between the two is somewhat arbitrary.
  20146. #
  20147. #     For each token, we will define two variables which would apply if
  20148. #     the current statement were broken just before that token, so that
  20149. #     that token started a new line:
  20150. #
  20151. #     $level = the structural indentation level,
  20152. #     $ci_level = the continuation indentation level
  20153. #
  20154. #     The total indentation will be $level * (4 spaces) + $ci_level * (2 spaces),
  20155. #     assuming defaults.  However, in some special cases it is customary
  20156. #     to modify $ci_level from this strict value.
  20157. #
  20158. #     The total structural indentation is easy to compute by adding and
  20159. #     subtracting 1 from a saved value as types '{' and '}' are seen.  The
  20160. #     running value of this variable is $level_in_tokenizer.
  20161. #
  20162. #     The total continuation is much more difficult to compute, and requires
  20163. #     several variables.  These veriables are:
  20164. #
  20165. #     $ci_string_in_tokenizer = a string of 1's and 0's indicating, for
  20166. #       each indentation level, if there are intervening open secondary
  20167. #       structures just prior to that level.
  20168. #     $continuation_string_in_tokenizer = a string of 1's and 0's indicating
  20169. #       if the last token at that level is "continued", meaning that it
  20170. #       is not the first token of an expression.
  20171. #     $nesting_block_string = a string of 1's and 0's indicating, for each
  20172. #       indentation level, if the level is of type BLOCK or not.
  20173. #     $nesting_block_flag = the most recent 1 or 0 of $nesting_block_string
  20174. #     $nesting_list_string = a string of 1's and 0's indicating, for each
  20175. #       indentation level, if it is is appropriate for list formatting.
  20176. #       If so, continuation indentation is used to indent long list items.
  20177. #     $nesting_list_flag = the most recent 1 or 0 of $nesting_list_string
  20178. #     @slevel_stack = a stack of total nesting depths at each
  20179. #       structural indentation level, where "total nesting depth" means
  20180. #       the nesting depth that would occur if every nesting token -- '{', '[',
  20181. #       and '(' -- , regardless of context, is used to compute a nesting
  20182. #       depth.
  20183.  
  20184.         #my $nesting_block_flag = ($nesting_block_string =~ /1$/);
  20185.         #my $nesting_list_flag = ($nesting_list_string =~ /1$/);
  20186.  
  20187.         my ( $ci_string_i, $level_i, $nesting_block_string_i,
  20188.             $nesting_list_string_i, $nesting_token_string_i,
  20189.             $nesting_type_string_i, );
  20190.  
  20191.         foreach $i (@output_token_list) {  # scan the list of pre-tokens indexes
  20192.  
  20193.             # self-checking for valid token types
  20194.             my $type = $output_token_type[$i];
  20195.             my $tok = $$rtokens[$i];   # the token, but ONLY if same as pretoken
  20196.             $level_i = $level_in_tokenizer;
  20197.  
  20198.             # This can happen by running perltidy on non-scripts
  20199.             # although it could also be bug introduced by programming change.
  20200.             # Perl silently accepts a 032 (^Z) and takes it as the end
  20201.             if ( !$is_valid_token_type{$type} ) {
  20202.                 my $val = ord($type);
  20203.                 warning(
  20204.                     "unexpected character decimal $val ($type) in script\n");
  20205.                 $tokenizer_self->{_in_error} = 1;
  20206.             }
  20207.  
  20208.             # ----------------------------------------------------------------
  20209.             # TOKEN TYPE PATCHES
  20210.             #  output __END__, __DATA__, and format as type 'k' instead of ';'
  20211.             # to make html colors correct, etc.
  20212.             my $fix_type = $type;
  20213.             if ( $type eq ';' && $tok =~ /\w/ ) { $fix_type = 'k' }
  20214.  
  20215.             # output anonymous 'sub' as keyword
  20216.             if ( $type eq 't' && $tok eq 'sub' ) { $fix_type = 'k' }
  20217.  
  20218.             # -----------------------------------------------------------------
  20219.  
  20220.             $nesting_token_string_i = $nesting_token_string;
  20221.             $nesting_type_string_i  = $nesting_type_string;
  20222.             $nesting_block_string_i = $nesting_block_string;
  20223.             $nesting_list_string_i  = $nesting_list_string;
  20224.  
  20225.             # set primary indentation levels based on structural braces
  20226.             # Note: these are set so that the leading braces have a HIGHER
  20227.             # level than their CONTENTS, which is convenient for indentation
  20228.             # Also, define continuation indentation for each token.
  20229.             if ( $type eq '{' || $type eq 'L' ) {
  20230.  
  20231.                 # use environment before updating
  20232.                 $container_environment =
  20233.                   $nesting_block_flag  ? 'BLOCK'
  20234.                   : $nesting_list_flag ? 'LIST'
  20235.                   : "";
  20236.  
  20237.                 # if the difference between total nesting levels is not 1,
  20238.                 # there are intervening non-structural nesting types between
  20239.                 # this '{' and the previous unclosed '{'
  20240.                 my $intervening_secondary_structure = 0;
  20241.                 if (@slevel_stack) {
  20242.                     $intervening_secondary_structure =
  20243.                       $slevel_in_tokenizer - $slevel_stack[-1];
  20244.                 }
  20245.  
  20246.      # =head1 Continuation Indentation
  20247.      #
  20248.      # Having tried setting continuation indentation both in the formatter and
  20249.      # in the tokenizer, I can say that setting it in the tokenizer is much,
  20250.      # much easier.  The formatter already has too much to do, and can't
  20251.      # make decisions on line breaks without knowing what 'ci' will be at
  20252.      # arbitrary locations.
  20253.      #
  20254.      # But a problem with setting the continuation indentation (ci) here
  20255.      # in the tokenizer is that we do not know where line breaks will actually
  20256.      # be.  As a result, we don't know if we should propagate continuation
  20257.      # indentation to higher levels of structure.
  20258.      #
  20259.      # For nesting of only structural indentation, we never need to do this.
  20260.      # For example, in a long if statement, like this
  20261.      #
  20262.      #   if ( !$output_block_type[$i]
  20263.      #     && ($in_statement_continuation) )
  20264.      #   {           <--outdented
  20265.      #       do_something();
  20266.      #   }
  20267.      #
  20268.      # the second line has ci but we do normally give the lines within the BLOCK
  20269.      # any ci.  This would be true if we had blocks nested arbitrarily deeply.
  20270.      #
  20271.      # But consider something like this, where we have created a break after
  20272.      # an opening paren on line 1, and the paren is not (currently) a
  20273.      # structural indentation token:
  20274.      #
  20275.      # my $file = $menubar->Menubutton(
  20276.      #   qw/-text File -underline 0 -menuitems/ => [
  20277.      #       [
  20278.      #           Cascade    => '~View',
  20279.      #           -menuitems => [
  20280.      #           ...
  20281.      #
  20282.      # The second line has ci, so it would seem reasonable to propagate it
  20283.      # down, giving the third line 1 ci + 1 indentation.  This suggests the
  20284.      # following rule, which is currently used to propagating ci down: if there
  20285.      # are any non-structural opening parens (or brackets, or braces), before
  20286.      # an opening structural brace, then ci is propagated down, and otherwise
  20287.      # not.  The variable $intervening_secondary_structure contains this
  20288.      # information for the current token, and the string
  20289.      # "$ci_string_in_tokenizer" is a stack of previous values of this
  20290.      # variable.
  20291.  
  20292.                 # save the current states
  20293.                 push ( @slevel_stack, 1 + $slevel_in_tokenizer );
  20294.                 $level_in_tokenizer++;
  20295.  
  20296.                 if ( $output_block_type[$i] ) {
  20297.                     $nesting_block_flag = 1;
  20298.                     $nesting_block_string .= '1';
  20299.                 }
  20300.                 else {
  20301.                     $nesting_block_flag = 0;
  20302.                     $nesting_block_string .= '0';
  20303.                 }
  20304.  
  20305.                 # we will use continuation indentation within containers
  20306.                 # which are not blocks and not logical expressions
  20307.                 my $bit = 0;
  20308.                 if ( !$output_block_type[$i] ) {
  20309.  
  20310.                     # propagate flag down at nested open parens
  20311.                     if ( $output_container_type[$i] eq '(' ) {
  20312.                         $bit = 1 if $nesting_list_flag;
  20313.                     }
  20314.  
  20315.                   # use list continuation if not a logical grouping
  20316.                   # /^(if|elsif|unless|while|and|or|not|&&|!|\|\||for|foreach)$/
  20317.                     else {
  20318.                         $bit = 1
  20319.                           unless
  20320.                           $is_logical_container{ $output_container_type[$i] };
  20321.                     }
  20322.                 }
  20323.                 $nesting_list_string .= $bit;
  20324.                 $nesting_list_flag = $bit;
  20325.  
  20326.                 $ci_string_in_tokenizer .=
  20327.                   ( $intervening_secondary_structure != 0 ) ? '1' : '0';
  20328.                 $ci_string_sum = ( $_ = $ci_string_in_tokenizer ) =~ tr/1/0/;
  20329.                 $continuation_string_in_tokenizer .=
  20330.                   ( $in_statement_continuation > 0 ) ? '1' : '0';
  20331.  
  20332.    #  Sometimes we want to give an opening brace continuation indentation,
  20333.    #  and sometimes not.  For code blocks, we don't do it, so that the leading
  20334.    #  '{' gets outdented, like this:
  20335.    #
  20336.    #   if ( !$output_block_type[$i]
  20337.    #     && ($in_statement_continuation) )
  20338.    #   {           <--outdented
  20339.    #
  20340.    #  For other types, we will give them continuation indentation.  For example,
  20341.    #  here is how a list looks with the opening paren indented:
  20342.    #
  20343.    #     @LoL =
  20344.    #       ( [ "fred", "barney" ], [ "george", "jane", "elroy" ],
  20345.    #         [ "homer", "marge", "bart" ], );
  20346.    #
  20347.    #  This looks best when 'ci' is one-half of the indentation  (i.e., 2 and 4)
  20348.  
  20349.                 my $total_ci = $ci_string_sum;
  20350.                 if (
  20351.                     !$output_block_type[$i]    # patch: skip for BLOCK
  20352.                     && ($in_statement_continuation)
  20353.                   )
  20354.                 {
  20355.                     $total_ci += $in_statement_continuation
  20356.                       unless ( $ci_string_in_tokenizer =~ /1$/ );
  20357.                 }
  20358.  
  20359.                 $ci_string_i               = $total_ci;
  20360.                 $in_statement_continuation = 0;
  20361.             }
  20362.  
  20363.             elsif ( $type eq '}' || $type eq 'R' ) {
  20364.  
  20365.                 # only a nesting error in the script would prevent popping here
  20366.                 if ( @slevel_stack > 1 ) { pop (@slevel_stack); }
  20367.  
  20368.                 $level_i = --$level_in_tokenizer;
  20369.  
  20370.                 # restore previous level values
  20371.                 if ( length($nesting_block_string) > 1 )
  20372.                 {    # true for valid script
  20373.                     chop $nesting_block_string;
  20374.                     $nesting_block_flag = ( $nesting_block_string =~ /1$/ );
  20375.                     chop $nesting_list_string;
  20376.                     $nesting_list_flag = ( $nesting_list_string =~ /1$/ );
  20377.  
  20378.                     chop $ci_string_in_tokenizer;
  20379.                     $ci_string_sum =
  20380.                       ( $_ = $ci_string_in_tokenizer ) =~ tr/1/0/;
  20381.  
  20382.                     $in_statement_continuation =
  20383.                       chop $continuation_string_in_tokenizer;
  20384.  
  20385.                     # zero continuation flag at terminal BLOCK '}' which
  20386.                     # ends a statement.
  20387.                     if ( $output_block_type[$i] ) {
  20388.  
  20389.                         # ...These include non-anonymous subs
  20390.                         # note: could be sub ::abc { or sub 'abc
  20391.                         if ( $output_block_type[$i] =~ m/^sub\s*/gc ) {
  20392.  
  20393.                          # note: older versions of perl require the /gc modifier
  20394.                          # here or else the \G does not work.
  20395.                             if ( $output_block_type[$i] =~ /\G('|::|\w)/gc ) {
  20396.                                 $in_statement_continuation = 0;
  20397.                             }
  20398.                         }
  20399.  
  20400. # ...and include all block types except user subs with
  20401. # block prototypes and these: (sort|grep|map|do|eval)
  20402. # /^(\}|\{|BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|continue|;|if|elsif|else|unless|while|until|for|foreach)$/
  20403.                         elsif (
  20404.                             $is_zero_continuation_block_type{ $output_block_type
  20405.                                   [$i] } )
  20406.                         {
  20407.                             $in_statement_continuation = 0;
  20408.                         }
  20409.  
  20410.                         # ..but these are not terminal types:
  20411.                         #     /^(sort|grep|map|do|eval)$/ )
  20412.                         elsif (
  20413.                             $is_not_zero_continuation_block_type{
  20414.                                 $output_block_type[$i] } )
  20415.                         {
  20416.                         }
  20417.  
  20418.                         # ..and a block introduced by a label
  20419.                         # /^\w+\s*:$/gc ) {
  20420.                         elsif ( $output_block_type[$i] =~ /:$/ ) {
  20421.                             $in_statement_continuation = 0;
  20422.                         }
  20423.  
  20424.                         # ..nor user function with block prototype
  20425.                         else {
  20426.                         }
  20427.                     }
  20428.  
  20429.                     # If we are in a list, then
  20430.                     # we must set continuatoin indentation at the closing
  20431.                     # paren of something like this (paren after $check):
  20432.                     #     assert(
  20433.                     #         __LINE__,
  20434.                     #         ( not defined $check )
  20435.                     #           or ref $check
  20436.                     #           or $check eq "new"
  20437.                     #           or $check eq "old",
  20438.                     #     );
  20439.                     elsif ( $tok eq ')' ) {
  20440.                         $in_statement_continuation = 1
  20441.                           if $output_container_type[$i] =~ /^[;,\{\}]$/;
  20442.                     }
  20443.                 }
  20444.  
  20445.                 # use environment after updating
  20446.                 $container_environment =
  20447.                   $nesting_block_flag  ? 'BLOCK'
  20448.                   : $nesting_list_flag ? 'LIST'
  20449.                   : "";
  20450.                 $ci_string_i = $ci_string_sum + $in_statement_continuation;
  20451.                 $nesting_block_string_i = $nesting_block_string;
  20452.                 $nesting_list_string_i  = $nesting_list_string;
  20453.             }
  20454.  
  20455.             # not a structural indentation type..
  20456.             else {
  20457.  
  20458.                 $container_environment =
  20459.                   $nesting_block_flag  ? 'BLOCK'
  20460.                   : $nesting_list_flag ? 'LIST'
  20461.                   : "";
  20462.  
  20463.                 # zero the continuation indentation at certain tokens so
  20464.                 # that they will be at the same level as its container.  For
  20465.                 # commas, this simplifies the -lp indentation logic, which
  20466.                 # counts commas.  For ?: it makes them stand out.
  20467.                 if ($nesting_list_flag) {
  20468.                     if ( $type =~ /^[,\?\:]$/ ) {
  20469.                         $in_statement_continuation = 0;
  20470.                     }
  20471.                 }
  20472.  
  20473.                 # be sure binary operators get continuation indentation
  20474.                 if ( $is_binary_type{$type} && $container_environment ) {
  20475.                     $in_statement_continuation = 1;
  20476.                 }
  20477.  
  20478.                 # continuation indentation is sum of any open ci from previous
  20479.                 # levels plus the current level
  20480.                 $ci_string_i = $ci_string_sum + $in_statement_continuation;
  20481.  
  20482.                 # update continuation flag ...
  20483.                 # if this isn't a blank or comment..
  20484.                 if ( $type ne 'b' && $type ne '#' ) {
  20485.  
  20486.                     # and we are in a BLOCK
  20487.                     if ($nesting_block_flag) {
  20488.  
  20489.                         # the next token after a ';' and label starts a new stmt
  20490.                         if ( $type eq ';' || $type eq 'J' ) {
  20491.                             $in_statement_continuation = 0;
  20492.                         }
  20493.  
  20494.                         # otherwise, we are continuing the current statement
  20495.                         else {
  20496.                             $in_statement_continuation = 1;
  20497.                         }
  20498.                     }
  20499.  
  20500.                     # if we are not in a BLOCK..
  20501.                     else {
  20502.  
  20503.                         # do not use continuation indentation if not list
  20504.                         # environment (could be within if/elsif clause)
  20505.                         if ( !$nesting_list_flag ) {
  20506.                             $in_statement_continuation = 0;
  20507.                         }
  20508.  
  20509.                        # otherwise, the next token after a ',' starts a new term
  20510.                         elsif ( $type eq ',' ) {
  20511.                             $in_statement_continuation = 0;
  20512.                         }
  20513.  
  20514.                         # otherwise, we are continuing the current term
  20515.                         else {
  20516.                             $in_statement_continuation = 1;
  20517.                         }
  20518.                     }
  20519.                 }
  20520.             }
  20521.  
  20522.             if ( $level_in_tokenizer < 0 ) {
  20523.                 unless ($saw_negative_indentation) {
  20524.                     $saw_negative_indentation = 1;
  20525.                     warning("Starting negative indentation\n");
  20526.                 }
  20527.             }
  20528.  
  20529.             # set secondary nesting levels based on all continment token types
  20530.             # Note: these are set so that the nesting depth is the depth
  20531.             # of the PREVIOUS TOKEN, which is convenient for setting
  20532.             # the stength of token bonds
  20533.             my $slevel_i = $slevel_in_tokenizer;
  20534.  
  20535.             #    /^[L\{\(\[]$/
  20536.             if ( $is_opening_type{$type} ) {
  20537.                 $slevel_in_tokenizer++;
  20538.                 $nesting_token_string .= $tok;
  20539.                 $nesting_type_string .= $type;
  20540.             }
  20541.  
  20542.             #       /^[R\}\)\]]$/
  20543.             elsif ( $is_closing_type{$type} ) {
  20544.                 $slevel_in_tokenizer--;
  20545.                 my $char = chop $nesting_token_string;
  20546.  
  20547.                 if ( $char ne $matching_start_token{$tok} ) {
  20548.                     $nesting_token_string .= $char . $tok;
  20549.                     $nesting_type_string .= $type;
  20550.                 }
  20551.                 else {
  20552.                     chop $nesting_type_string;
  20553.                 }
  20554.             }
  20555.  
  20556.             push ( @block_type,            $output_block_type[$i] );
  20557.             push ( @ci_string,             $ci_string_i );
  20558.             push ( @container_environment, $container_environment );
  20559.             push ( @container_type,        $output_container_type[$i] );
  20560.             push ( @levels,                $level_i );
  20561.             push ( @nesting_tokens,        $nesting_token_string_i );
  20562.             push ( @nesting_types,         $nesting_type_string_i );
  20563.             push ( @slevels,               $slevel_i );
  20564.             push ( @token_type,            $fix_type );
  20565.             push ( @type_sequence,         $output_type_sequence[$i] );
  20566.             push ( @nesting_blocks,        $nesting_block_string );
  20567.             push ( @nesting_lists,         $nesting_list_string );
  20568.  
  20569.             # now form the previous token
  20570.             if ( $im >= 0 ) {
  20571.                 $num =
  20572.                   $$rtoken_map[$i] - $$rtoken_map[$im];    # how many characters
  20573.  
  20574.                 if ( $num > 0 ) {
  20575.                     push ( @tokens,
  20576.                         substr( $input_line, $$rtoken_map[$im], $num ) );
  20577.                 }
  20578.             }
  20579.             $im = $i;
  20580.         }
  20581.  
  20582.         $num = length($input_line) - $$rtoken_map[$im];    # make the last token
  20583.         if ( $num > 0 ) {
  20584.             push ( @tokens, substr( $input_line, $$rtoken_map[$im], $num ) );
  20585.         }
  20586.  
  20587.         $tokenizer_self->{_in_quote}          = $in_quote;
  20588.         $tokenizer_self->{_rhere_target_list} = \@here_target_list;
  20589.  
  20590.         $line_of_tokens->{_rtoken_type}            = \@token_type;
  20591.         $line_of_tokens->{_rtokens}                = \@tokens;
  20592.         $line_of_tokens->{_rblock_type}            = \@block_type;
  20593.         $line_of_tokens->{_rcontainer_type}        = \@container_type;
  20594.         $line_of_tokens->{_rcontainer_environment} = \@container_environment;
  20595.         $line_of_tokens->{_rtype_sequence}         = \@type_sequence;
  20596.         $line_of_tokens->{_rlevels}                = \@levels;
  20597.         $line_of_tokens->{_rslevels}               = \@slevels;
  20598.         $line_of_tokens->{_rnesting_tokens}        = \@nesting_tokens;
  20599.         $line_of_tokens->{_rci_levels}             = \@ci_string;
  20600.         $line_of_tokens->{_rnesting_blocks}        = \@nesting_blocks;
  20601.  
  20602.         return;
  20603.     }
  20604. }    # end tokenize_this_line
  20605.  
  20606. sub new_statement_ok {
  20607.  
  20608.     # return true if the current token can start a new statement
  20609.  
  20610.     return label_ok()    # a label would be ok here
  20611.  
  20612.       || $last_nonblank_type eq 'J';    # or we follow a label
  20613.  
  20614. }
  20615.  
  20616. sub label_ok {
  20617.  
  20618.     # Decide if a bare word followed by a colon here is a label
  20619.  
  20620.     # if it follows an opening or closing code block curly brace..
  20621.     if ( ( $last_nonblank_token eq '{' || $last_nonblank_token eq '}' )
  20622.         && $last_nonblank_type eq $last_nonblank_token )
  20623.     {
  20624.  
  20625.         # it is a label if and only if the curly encloses a code block
  20626.         return $brace_type[$brace_depth];
  20627.     }
  20628.  
  20629.     # otherwise, it is a label if and only if it follows a ';'
  20630.     # (real or fake)
  20631.     else {
  20632.         return ( $last_nonblank_type eq ';' );
  20633.     }
  20634. }
  20635.  
  20636. sub code_block_type {
  20637.  
  20638.     # Decide if this is a block of code, and its type.
  20639.     # Must be called only when $type = $token = '{'
  20640.     # The problem is to distinguish between the start of a block of code
  20641.     # and the start of an anonymous hash reference
  20642.     # Returns "" if not code block, otherwise returns 'last_nonblank_token'
  20643.     # to indicate the type of code block.  (For example, 'last_nonblank_token'
  20644.     # might be 'if' for an if block, 'else' for an else block, etc).
  20645.  
  20646.     # handle case of multiple '{'s
  20647.  
  20648. # print "BLOCK_TYPE EXAMINING: type=$last_nonblank_type tok=$last_nonblank_token\n";
  20649.  
  20650.     my ( $i, $rtokens ) = @_;
  20651.     if (   $last_nonblank_token eq '{'
  20652.         && $last_nonblank_type eq $last_nonblank_token )
  20653.     {
  20654.  
  20655.         # opening brace where a statement may appear is probably
  20656.         # a code block but might be and anonymous hash reference
  20657.         if ( $brace_type[$brace_depth] ) {
  20658.             return decide_if_code_block( $i, $rtokens );
  20659.         }
  20660.  
  20661.         # cannot start a code block within an anonymous hash
  20662.         else {
  20663.             return "";
  20664.         }
  20665.     }
  20666.  
  20667.     elsif ( $last_nonblank_token eq ';' ) {
  20668.  
  20669.         # an opening brace where a statement may appear is probably
  20670.         # a code block but might be and anonymous hash reference
  20671.         return decide_if_code_block( $i, $rtokens );
  20672.     }
  20673.  
  20674.     # handle case of '}{'
  20675.     elsif ($last_nonblank_token eq '}'
  20676.         && $last_nonblank_type eq $last_nonblank_token )
  20677.     {
  20678.  
  20679.         # a } { situation ...
  20680.         # could be hash reference after code block..(blktype1.t)
  20681.         if ($last_nonblank_block_type) {
  20682.             return decide_if_code_block( $i, $rtokens );
  20683.         }
  20684.  
  20685.         # must be a block if it follows a closing hash reference
  20686.         else {
  20687.             return $last_nonblank_token;
  20688.         }
  20689.     }
  20690.  
  20691.     # NOTE: braces after type characters start code blocks, but for
  20692.     # simplicity these are not identified as such.  See also
  20693.     # sub is_non_structural_brace.
  20694.     # elsif ( $last_nonblank_type eq 't' ) {
  20695.     #    return $last_nonblank_token;
  20696.     # }
  20697.  
  20698.     # brace after label:
  20699.     elsif ( $last_nonblank_type eq 'J' ) {
  20700.         return $last_nonblank_token;
  20701.     }
  20702.  
  20703. # otherwise, look at previous token.  This must be a code block if
  20704. # it follows any of these:
  20705. # /^(BEGIN|END|CHECK|INIT|AUTOLOAD|DESTROY|continue|if|elsif|else|unless|do|while|until|eval|for|foreach|map|grep|sort)$/
  20706.     elsif ( $is_code_block_token{$last_nonblank_token} ) {
  20707.         return $last_nonblank_token;
  20708.     }
  20709.  
  20710.     # or a sub definition
  20711.     elsif ( ( $last_nonblank_type eq 'i' || $last_nonblank_type eq 't' )
  20712.         && $last_nonblank_token =~ /^sub\b/ )
  20713.     {
  20714.         return $last_nonblank_token;
  20715.     }
  20716.  
  20717.     # user-defined subs with block parameters (like grep/map/eval)
  20718.     elsif ( $last_nonblank_type eq 'G' ) {
  20719.         return $last_nonblank_token;
  20720.     }
  20721.  
  20722.     # anything else must be anonymous hash reference
  20723.     else {
  20724.         return "";
  20725.     }
  20726. }
  20727.  
  20728. sub decide_if_code_block {
  20729.  
  20730.     my ( $i, $rtokens ) = @_;
  20731.     my ( $next_nonblank_token, $i_next ) =
  20732.       find_next_nonblank_token( $i, $rtokens );
  20733.  
  20734.     # we are at a '{' where a statement may appear.
  20735.     # We must decide if this brace starts an anonymous hash or a code
  20736.     # block.
  20737.     # return "" if anonymous hash, and $last_nonblank_token otherwise
  20738.  
  20739.     # initialize to be code BLOCK
  20740.     my $code_block_type = $last_nonblank_token;
  20741.  
  20742.     # Check for an empty anonymous hash reference:
  20743.     # Maybe something like sub { { } }
  20744.     if ( $next_nonblank_token eq '}' ) {
  20745.         $code_block_type = "";
  20746.     }
  20747.  
  20748.     # FIXME: coding incomplete
  20749.  
  20750.     return $code_block_type;
  20751. }
  20752.  
  20753. sub unexpected {
  20754.  
  20755.     # report unexpected token type and show where it is
  20756.     my ( $found, $expecting, $i_tok, $last_nonblank_i ) = @_;
  20757.     $unexpected_error_count++;
  20758.     if ( $unexpected_error_count <= MAX_NAG_MESSAGES ) {
  20759.         my $msg = "found $found where $expecting expected";
  20760.         my $pos = $$rpretoken_map[$i_tok];
  20761.         interrupt_logfile();
  20762.         my ( $offset, $numbered_line, $underline ) =
  20763.           make_numbered_line( $input_line_number, $input_line, $pos );
  20764.         $underline = write_on_underline( $underline, $pos - $offset, '^' );
  20765.  
  20766.         my $trailer = "";
  20767.         if ( ( $i_tok > 0 ) && ( $last_nonblank_i >= 0 ) ) {
  20768.             my $pos_prev = $$rpretoken_map[$last_nonblank_i];
  20769.             my $num;
  20770.             if ( $$rpretoken_type[ $i_tok - 1 ] eq 'b' ) {
  20771.                 $num = $$rpretoken_map[ $i_tok - 1 ] - $pos_prev;
  20772.             }
  20773.             else {
  20774.                 $num = $pos - $pos_prev;
  20775.             }
  20776.             if ( $num > 40 ) { $num = 40; $pos_prev = $pos - 40; }
  20777.  
  20778.             $underline =
  20779.               write_on_underline( $underline, $pos_prev - $offset, '-' x $num );
  20780.             $trailer = " (previous token underlined)";
  20781.         }
  20782.         warning( $numbered_line . "\n" );
  20783.         warning( $underline . "\n" );
  20784.         warning( $msg . $trailer . "\n" );
  20785.         resume_logfile();
  20786.     }
  20787. }
  20788.  
  20789. sub indicate_error {
  20790.     my ( $msg, $line_number, $input_line, $pos, $carrat ) = @_;
  20791.     interrupt_logfile();
  20792.     warning($msg);
  20793.     write_error_indicator_pair( $line_number, $input_line, $pos, $carrat );
  20794.     resume_logfile();
  20795. }
  20796.  
  20797. sub write_error_indicator_pair {
  20798.     my ( $line_number, $input_line, $pos, $carrat ) = @_;
  20799.     my ( $offset, $numbered_line, $underline ) =
  20800.       make_numbered_line( $line_number, $input_line, $pos );
  20801.     $underline = write_on_underline( $underline, $pos - $offset, $carrat );
  20802.     warning( $numbered_line . "\n" );
  20803.     $underline =~ s/\s*$//;
  20804.     warning( $underline . "\n" );
  20805. }
  20806.  
  20807. sub make_numbered_line {
  20808.  
  20809.     #  Given an input line, its line number, and a character position of
  20810.     #  interest, create a string not longer than 80 characters of the form
  20811.     #     $lineno: sub_string
  20812.     #  such that the sub_string of $str contains the position of interest
  20813.     #
  20814.     #  Here is an example of what we want, in this case we add trailing
  20815.     #  '...' because the line is long.
  20816.     #
  20817.     # 2: (One of QAML 2.0's authors is a member of the World Wide Web Con ...
  20818.     #
  20819.     #  Here is another example, this time in which we used leading '...'
  20820.     #  because of excessive length:
  20821.     #
  20822.     # 2: ... er of the World Wide Web Consortium's
  20823.     #
  20824.     #  input parameters are:
  20825.     #   $lineno = line number
  20826.     #   $str = the text of the line
  20827.     #   $pos = position of interest (the error) : 0 = first character
  20828.     #
  20829.     #   We return :
  20830.     #     - $offset = an offset which corrects the position in case we only
  20831.     #       display part of a line, such that $pos-$offset is the effective
  20832.     #       position from the start of the displayed line.
  20833.     #     - $numbered_line = the numbered line as above,
  20834.     #     - $underline = a blank 'underline' which is all spaces with the same
  20835.     #       number of characters as the numbered line.
  20836.  
  20837.     my ( $lineno, $str, $pos ) = @_;
  20838.     my $offset = ( $pos < 60 ) ? 0 : $pos - 40;
  20839.     my $excess = length($str) - $offset - 68;
  20840.     my $numc   = ( $excess > 0 ) ? 68 : undef;
  20841.  
  20842.     if ( defined($numc) ) {
  20843.         if ( $offset == 0 ) {
  20844.             $str = substr( $str, $offset, $numc - 4 ) . " ...";
  20845.         }
  20846.         else {
  20847.             $str = "... " . substr( $str, $offset + 4, $numc - 4 ) . " ...";
  20848.         }
  20849.     }
  20850.     else {
  20851.  
  20852.         if ( $offset == 0 ) {
  20853.         }
  20854.         else {
  20855.             $str = "... " . substr( $str, $offset + 4 );
  20856.         }
  20857.     }
  20858.  
  20859.     my $numbered_line = sprintf( "%d: ", $lineno );
  20860.     $offset -= length($numbered_line);
  20861.     $numbered_line .= $str;
  20862.     my $underline = " " x length($numbered_line);
  20863.     return ( $offset, $numbered_line, $underline );
  20864. }
  20865.  
  20866. sub write_on_underline {
  20867.  
  20868.     # The "underline" is a string that shows where an error is; it starts
  20869.     # out as a string of blanks with the same length as the numbered line of
  20870.     # code above it, and we have to add marking to show where an error is.
  20871.     # In the example below, we want to write the string '--^' just below
  20872.     # the line of bad code:
  20873.     #
  20874.     # 2: (One of QAML 2.0's authors is a member of the World Wide Web Con ...
  20875.     #                 ---^
  20876.     # We are given the current underline string, plus a position and a
  20877.     # string to write on it.
  20878.     #
  20879.     # In the above example, there will be 2 calls to do this:
  20880.     # First call:  $pos=19, pos_chr=^
  20881.     # Second call: $pos=16, pos_chr=---
  20882.     #
  20883.     # This is a trivial thing to do with substr, but there is some
  20884.     # checking to do.
  20885.  
  20886.     my ( $underline, $pos, $pos_chr ) = @_;
  20887.  
  20888.     # check for error..shouldn't happen
  20889.     unless ( ( $pos >= 0 ) && ( $pos <= length($underline) ) ) {
  20890.         return $underline;
  20891.     }
  20892.     my $excess = length($pos_chr) + $pos - length($underline);
  20893.     if ( $excess > 0 ) {
  20894.         $pos_chr = substr( $pos_chr, 0, length($pos_chr) - $excess );
  20895.     }
  20896.     substr( $underline, $pos, length($pos_chr) ) = $pos_chr;
  20897.     return ($underline);
  20898. }
  20899.  
  20900. sub is_non_structural_brace {
  20901.  
  20902.     # Decide if a brace or bracket is structural or non-structural
  20903.     # by looking at the previous token and type
  20904.  
  20905.     # EXPERIMENTAL: Mark slices as structural; idea was to improve formatting.
  20906.     # Tentatively deactivated because it caused the wrong operator expectation
  20907.     # for this code:
  20908.     #      $user = @vars[1] / 100;
  20909.     # Must update sub operator_expected before re-implementing.
  20910.     # if ( $last_nonblank_type eq 'i' && $last_nonblank_token =~ /^@/ ) {
  20911.     #    return 0;
  20912.     # }
  20913.  
  20914.     # NOTE: braces after type characters start code blocks, but for
  20915.     # simplicity these are not identified as such.  See also
  20916.     # sub code_block_type
  20917.     # if ($last_nonblank_type eq 't') {return 0}
  20918.  
  20919.     # otherwise, it is non-structural if it is decorated
  20920.     # by type information.
  20921.     # For example, the '{' here is non-structural:   ${xxx}
  20922.     (
  20923.         $last_nonblank_token =~ /^([\$\@\*\&\%\)]|->|::)/
  20924.  
  20925.           # or if we follow a hash or array closing curly brace or bracket
  20926.           # For example, the second '{' in this is non-structural: $a{'x'}{'y'}
  20927.           # because the first '}' would have been given type 'R'
  20928.           || $last_nonblank_type =~ /^([R\]])$/
  20929.     );
  20930. }
  20931.  
  20932. sub operator_expected {
  20933.  
  20934.     # Many perl symbols have two or more meanings.  For example, '<<'
  20935.     # can be a shift operator or a here-doc operator.  The
  20936.     # interpretation of these symbols depends on the current state of
  20937.     # the tokenizer, which may either be expecting a term or an
  20938.     # operator.  For this example, a << would be a shift if an operator
  20939.     # is expected, and a here-doc if a term is expected.  This routine
  20940.     # is called to make this decision for any current token.  It returns
  20941.     # one of three possible values:
  20942.     #
  20943.     #     OPERATOR - operator expected (or at least, not a term)
  20944.     #     UNKNOWN  - can't tell
  20945.     #     TERM     - a term is expected (or at least, not an operator)
  20946.     #
  20947.     # The decision is based on what has been seen so far.  This
  20948.     # information is stored in the "$last_nonblank_type" and
  20949.     # "$last_nonblank_token" variables.  For example, if the
  20950.     # $last_nonblank_type is '=~', then we are expecting a TERM, whereas
  20951.     # if $last_nonblank_type is 'n' (numeric), we are expecting an
  20952.     # OPERATOR.
  20953.     #
  20954.     # If a UNKNOWN is returned, the calling routine must guess. A major
  20955.     # goal of this tokenizer is to minimize the possiblity of returning
  20956.     # UNKNOWN, because a wrong guess can spoil the formatting of a
  20957.     # script.
  20958.     #
  20959.     # adding NEW_TOKENS: it is critically important that this routine be
  20960.     # updated to allow it to determine if an operator or term is to be
  20961.     # expected after the new token.  Doing this simply involves adding
  20962.     # the new token character to one of the regexes in this routine or
  20963.     # to one of the hash lists
  20964.     # that it uses, which are initialized in the BEGIN section.
  20965.  
  20966.     my ( $prev_type, $tok, $next_type ) = @_;
  20967.     my $op_expected = UNKNOWN;
  20968.  
  20969. # Note: function prototype is available for token type 'U' for future
  20970. # program development.  It contains the leading and trailing parens,
  20971. # and no blanks.  It might be used to eliminate token type 'C', for
  20972. # example (prototype = '()'). Thus:
  20973. # if ($last_nonblank_type eq 'U') {
  20974. #     print "previous token=$last_nonblank_token  type=$last_nonblank_type prototype=$last_nonblank_prototype\n";
  20975. # }
  20976.  
  20977.     # A possible filehandle (or object) requires some care...
  20978.     if ( $last_nonblank_type eq 'Z' ) {
  20979.  
  20980.         # angle.t
  20981.         if ( $last_nonblank_token =~ /^[A-Za-z_]/ ) {
  20982.             $op_expected = UNKNOWN;
  20983.         }
  20984.  
  20985.         # For possible file handle like "$a", Perl uses weird parsing rules.
  20986.         # For example:
  20987.         # print $a/2,"/hi";   - division
  20988.         # print $a / 2,"/hi"; - division
  20989.         # print $a/ 2,"/hi";  - division
  20990.         # print $a /2,"/hi";  - pattern (and error)!
  20991.         elsif ( ( $prev_type eq 'b' ) && ( $next_type ne 'b' ) ) {
  20992.             $op_expected = TERM;
  20993.         }
  20994.  
  20995.         # Note when an operation is being done where a
  20996.         # filehandle might be expected, since a change in whitespace
  20997.         # could change the interpretation of the statement.
  20998.         else {
  20999.             if ( $tok =~ /^([x\/\+\-\*\%\&\.\?\<]|\>\>)$/ ) {
  21000.                 complain("operator in print statement not recommended\n");
  21001.                 $op_expected = OPERATOR;
  21002.             }
  21003.         }
  21004.     }
  21005.  
  21006.     # handle something after 'do' and 'eval'
  21007.     elsif ( $is_block_operator{$last_nonblank_token} ) {
  21008.  
  21009.         # something like $a = eval "expression";
  21010.         #                          ^
  21011.         if ( $last_nonblank_type eq 'k' ) {
  21012.             $op_expected = TERM;    # expression or list mode following keyword
  21013.         }
  21014.  
  21015.         # something like $a = do { BLOCK } / 2;
  21016.         #                                  ^
  21017.         else {
  21018.             $op_expected = OPERATOR;    # block mode following }
  21019.         }
  21020.     }
  21021.  
  21022.     # handle bare word..
  21023.     elsif ( $last_nonblank_type eq 'w' ) {
  21024.  
  21025.         # unfortunately, we can't tell what type of token to expect next
  21026.         # after most bare words
  21027.         $op_expected = UNKNOWN;
  21028.     }
  21029.  
  21030.     # operator, but not term possible after these types
  21031.     # Note: moved ')' from type to token because parens in list context
  21032.     # get marked as '{' '}' now.  This is a minor glitch in the following:
  21033.     #    my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
  21034.     #
  21035.     elsif (( $last_nonblank_type =~ /^[\]RnviQh]$/ )
  21036.         || ( $last_nonblank_token =~ /^(\)|\$|\-\>)/ ) )
  21037.     {
  21038.         $op_expected = OPERATOR;
  21039.  
  21040.         # in a 'use' statement, numbers and v-strings are not really
  21041.         # numbers, so to avoid incorrect error messages, we will
  21042.         # mark them as unknown for now (use.t)
  21043.         if (   ( $statement_type eq 'use' )
  21044.             && ( $last_nonblank_type =~ /^[nv]$/ ) )
  21045.         {
  21046.             $op_expected = UNKNOWN;
  21047.         }
  21048.     }
  21049.  
  21050.     # no operator after many keywords, such as "die", "warn", etc
  21051.     elsif ( $expecting_term_token{$last_nonblank_token} ) {
  21052.         $op_expected = TERM;
  21053.     }
  21054.  
  21055.     # no operator after things like + - **  (i.e., other operators)
  21056.     elsif ( $expecting_term_types{$last_nonblank_type} ) {
  21057.         $op_expected = TERM;
  21058.     }
  21059.  
  21060.     # a few operators, like "time", have an empty prototype () and so
  21061.     # take no parameters but produce a value to operate on
  21062.     elsif ( $expecting_operator_token{$last_nonblank_token} ) {
  21063.         $op_expected = OPERATOR;
  21064.     }
  21065.  
  21066.     # post-increment and decrement produce values to be operated on
  21067.     elsif ( $expecting_operator_types{$last_nonblank_type} ) {
  21068.         $op_expected = OPERATOR;
  21069.     }
  21070.  
  21071.     # no value to operate on after sub block
  21072.     elsif ( $last_nonblank_token =~ /^sub\s/ ) { $op_expected = TERM; }
  21073.  
  21074.     # a right brace here indicates the end of a simple block.
  21075.     # all non-structural right braces have type 'R'
  21076.     # all braces associated with block operator keywords have been given those
  21077.     # keywords as "last_nonblank_token" and caught above.
  21078.     # (This statement is order dependent, and must come after checking
  21079.     # $last_nonblank_token).
  21080.     elsif ( $last_nonblank_type eq '}' ) {
  21081.         $op_expected = TERM;
  21082.     }
  21083.  
  21084.     # something else..what did I forget?
  21085.     else {
  21086.  
  21087.         # collecting diagnostics on unknown operator types..see what was missed
  21088.         $op_expected = UNKNOWN;
  21089.         write_diagnostics(
  21090. "OP: unknown after type=$last_nonblank_type  token=$last_nonblank_token\n"
  21091.         );
  21092.     }
  21093.  
  21094.     TOKENIZER_DEBUG_FLAG_EXPECT && do {
  21095.         print
  21096. "EXPECT: returns $op_expected for last type $last_nonblank_type token $last_nonblank_token\n";
  21097.     };
  21098.     return $op_expected;
  21099. }
  21100.  
  21101. # The following routines keep track of nesting depths of the nesting
  21102. # types, ( [ { and ?.  This is necessary for determining the indentation
  21103. # level, and also for debugging programs.  Not only do they keep track of
  21104. # nesting depths of the individual brace types, but they check that each
  21105. # of the other brace types is balanced within matching pairs.  For
  21106. # example, if the program sees this sequence:
  21107. #
  21108. #         {  ( ( ) }
  21109. #
  21110. # then it can determine that there is an extra left paren somewhere
  21111. # between the { and the }.  And so on with every other possible
  21112. # combination of outer and inner brace types.  For another
  21113. # example:
  21114. #
  21115. #         ( [ ..... ]  ] )
  21116. #
  21117. # which has an extra ] within the parens.
  21118. #
  21119. # The brace types have indexes 0 .. 3 which are indexes into
  21120. # the matrices.
  21121. #
  21122. # The pair ? : are treated as just another nesting type, with ? acting
  21123. # as the opening brace and : acting as the closing brace.
  21124. #
  21125. # The matrix
  21126. #
  21127. #         $depth_array[$a][$b][ $current_depth[$a] ] = $current_depth[$b];
  21128. #
  21129. # saves the nesting depth of brace type $b (where $b is either of the other
  21130. # nesting types) when brace type $a enters a new depth.  When this depth
  21131. # decreases, a check is made that the current depth of brace types $b is
  21132. # unchanged, or otherwise there must have been an error.  This can
  21133. # be very useful for localizing errors, particularly when perl runs to
  21134. # the end of a large file (such as this one) and announces that there
  21135. # is a problem somewhere.
  21136. #
  21137. # A numerical sequence number is maintained for every nesting type,
  21138. # so that each matching pair can be uniquely identified in a simple
  21139. # way.
  21140.  
  21141. sub increase_nesting_depth {
  21142.     my ( $a, $i_tok ) = @_;
  21143.     my $b;
  21144.     $current_depth[$a]++;
  21145.  
  21146.     # Sequence numbers increment by number of items.  This keeps
  21147.     # a unique set of numbers but still allows the relative location
  21148.     # of any type to be determined.
  21149.     $nesting_sequence_number[$a] += scalar(@closing_brace_names);
  21150.     my $seqno = $nesting_sequence_number[$a];
  21151.     $current_sequence_number[$a][ $current_depth[$a] ] = $seqno;
  21152.  
  21153.     my $pos = $$rpretoken_map[$i_tok];
  21154.     $starting_line_of_current_depth[$a][ $current_depth[$a] ] =
  21155.       [ $input_line_number, $input_line, $pos ];
  21156.  
  21157.     for $b ( 0 .. $#closing_brace_names ) {
  21158.         next if ( $b == $a );
  21159.         $depth_array[$a][$b][ $current_depth[$a] ] = $current_depth[$b];
  21160.     }
  21161.     return $seqno;
  21162. }
  21163.  
  21164. sub decrease_nesting_depth {
  21165.  
  21166.     my ( $a, $i_tok ) = @_;
  21167.     my $pos = $$rpretoken_map[$i_tok];
  21168.     my $b;
  21169.     my $seqno = 0;
  21170.  
  21171.     if ( $current_depth[$a] > 0 ) {
  21172.  
  21173.         $seqno = $current_sequence_number[$a][ $current_depth[$a] ];
  21174.  
  21175.         # check that any brace types $b contained within are balanced
  21176.         for $b ( 0 .. $#closing_brace_names ) {
  21177.             next if ( $b == $a );
  21178.  
  21179.             unless ( $depth_array[$a][$b][ $current_depth[$a] ] ==
  21180.                 $current_depth[$b] )
  21181.             {
  21182.                 my $diff = $current_depth[$b] -
  21183.                   $depth_array[$a][$b][ $current_depth[$a] ];
  21184.  
  21185.                 # don't whine too many times
  21186.                 my $saw_brace_error = get_saw_brace_error();
  21187.                 if (
  21188.                     $saw_brace_error <= MAX_NAG_MESSAGES
  21189.  
  21190.                     # if too many closing types have occured, we probably
  21191.                     # already caught this error
  21192.                     && ( ( $diff > 0 ) || ( $saw_brace_error <= 0 ) )
  21193.                   )
  21194.                 {
  21195.                     interrupt_logfile();
  21196.                     my $rsl =
  21197.                       $starting_line_of_current_depth[$a][ $current_depth[$a] ];
  21198.                     my $sl  = $$rsl[0];
  21199.                     my $rel = [ $input_line_number, $input_line, $pos ];
  21200.                     my $el  = $$rel[0];
  21201.                     my ($ess);
  21202.  
  21203.                     if ( $diff == 1 || $diff == -1 ) {
  21204.                         $ess = '';
  21205.                     }
  21206.                     else {
  21207.                         $ess = 's';
  21208.                     }
  21209.                     my $bname =
  21210.                       ( $diff > 0 )
  21211.                       ? $opening_brace_names[$b]
  21212.                       : $closing_brace_names[$b];
  21213.                     write_error_indicator_pair( @$rsl, '^' );
  21214.                     my $msg = <<"EOM";
  21215. Found $diff extra $bname$ess between $opening_brace_names[$a] on line $sl and $closing_brace_names[$a] on line $el
  21216. EOM
  21217.  
  21218.                     if ( $diff > 0 ) {
  21219.                         my $rml =
  21220.                           $starting_line_of_current_depth[$b]
  21221.                           [ $current_depth[$b] ];
  21222.                         my $ml = $$rml[0];
  21223.                         $msg .=
  21224. "    The most recent un-matched $bname is on line $ml\n";
  21225.                         write_error_indicator_pair( @$rml, '^' );
  21226.                     }
  21227.                     write_error_indicator_pair( @$rel, '^' );
  21228.                     warning($msg);
  21229.                     resume_logfile();
  21230.                 }
  21231.                 increment_brace_error();
  21232.             }
  21233.         }
  21234.         $current_depth[$a]--;
  21235.     }
  21236.     else {
  21237.  
  21238.         my $saw_brace_error = get_saw_brace_error();
  21239.         if ( $saw_brace_error <= MAX_NAG_MESSAGES ) {
  21240.             my $msg = <<"EOM";
  21241. There is no previous $opening_brace_names[$a] to match a $closing_brace_names[$a] on line $input_line_number
  21242. EOM
  21243.             indicate_error( $msg, $input_line_number, $input_line, $pos, '^' );
  21244.         }
  21245.         increment_brace_error();
  21246.     }
  21247.     return $seqno;
  21248. }
  21249.  
  21250. sub check_final_nesting_depths {
  21251.     my ($a);
  21252.  
  21253.     for $a ( 0 .. $#closing_brace_names ) {
  21254.  
  21255.         if ( $current_depth[$a] ) {
  21256.             my $rsl = $starting_line_of_current_depth[$a][ $current_depth[$a] ];
  21257.             my $sl  = $$rsl[0];
  21258.             my $msg = <<"EOM";
  21259. Final nesting depth of $opening_brace_names[$a]s is $current_depth[$a]
  21260. The most recent un-matched $opening_brace_names[$a] is on line $sl
  21261. EOM
  21262.             indicate_error( $msg, @$rsl, '^' );
  21263.             increment_brace_error();
  21264.         }
  21265.     }
  21266. }
  21267.  
  21268. sub numerator_expected {
  21269.  
  21270.     # this is a filter for a possible numerator, in support of guessing
  21271.     # for the / pattern delimiter token.
  21272.     # returns -
  21273.     #   1 - yes
  21274.     #   0 - can't tell
  21275.     #  -1 - no
  21276.     # Note: I am using the convention that variables ending in
  21277.     # _expected have these 3 possible values.
  21278.     my ( $i, $rtokens ) = @_;
  21279.     my $next_token = $$rtokens[ $i + 1 ];
  21280.     if ( $next_token eq '=' ) { $i++; }    # handle /=
  21281.     my ( $next_nonblank_token, $i_next ) =
  21282.       find_next_nonblank_token( $i, $rtokens );
  21283.  
  21284.     if ( $next_nonblank_token =~ /(\(|\$|\w|\.|\@)/ ) {
  21285.         1;
  21286.     }
  21287.     else {
  21288.  
  21289.         if ( $next_nonblank_token =~ /^\s*$/ ) {
  21290.             0;
  21291.         }
  21292.         else {
  21293.             -1;
  21294.         }
  21295.     }
  21296. }
  21297.  
  21298. sub pattern_expected {
  21299.  
  21300.     # This is the start of a filter for a possible pattern.
  21301.     # It looks at the token after a possbible pattern and tries to
  21302.     # determine if that token could end a pattern.
  21303.     # returns -
  21304.     #   1 - yes
  21305.     #   0 - can't tell
  21306.     #  -1 - no
  21307.     my ( $i, $rtokens ) = @_;
  21308.     my $next_token = $$rtokens[ $i + 1 ];
  21309.     if ( $next_token =~ /^[cgimosx]/ ) { $i++; }    # skip possible modifier
  21310.     my ( $next_nonblank_token, $i_next ) =
  21311.       find_next_nonblank_token( $i, $rtokens );
  21312.  
  21313.     # list of tokens which may follow a pattern
  21314.     # (can probably be expanded)
  21315.     if ( $next_nonblank_token =~ /(\)|\}|\;|\&\&|\|\||and|or|while|if|unless)/ )
  21316.     {
  21317.         1;
  21318.     }
  21319.     else {
  21320.  
  21321.         if ( $next_nonblank_token =~ /^\s*$/ ) {
  21322.             0;
  21323.         }
  21324.         else {
  21325.             -1;
  21326.         }
  21327.     }
  21328. }
  21329.  
  21330. sub find_next_nonblank_token_on_this_line {
  21331.     my ( $i, $rtokens ) = @_;
  21332.     my $next_nonblank_token;
  21333.  
  21334.     if ( $i < $max_token_index ) {
  21335.         $next_nonblank_token = $$rtokens[ ++$i ];
  21336.  
  21337.         if ( $next_nonblank_token =~ /^\s*$/ ) {
  21338.  
  21339.             if ( $i < $max_token_index ) {
  21340.                 $next_nonblank_token = $$rtokens[ ++$i ];
  21341.             }
  21342.         }
  21343.     }
  21344.     else {
  21345.         $next_nonblank_token = "";
  21346.     }
  21347.     return ( $next_nonblank_token, $i );
  21348. }
  21349.  
  21350. sub find_next_nonblank_token {
  21351.     my ( $i, $rtokens ) = @_;
  21352.  
  21353.     if ( $i >= $max_token_index ) {
  21354.  
  21355.         if ( !$peeked_ahead ) {
  21356.             $peeked_ahead = 1;
  21357.             $rtokens      = peek_ahead_for_nonblank_token($rtokens);
  21358.         }
  21359.     }
  21360.     my $next_nonblank_token = $$rtokens[ ++$i ];
  21361.  
  21362.     if ( $next_nonblank_token =~ /^\s*$/ ) {
  21363.         $next_nonblank_token = $$rtokens[ ++$i ];
  21364.     }
  21365.     return ( $next_nonblank_token, $i );
  21366. }
  21367.  
  21368. sub peek_ahead_for_n_nonblank_pre_tokens {
  21369.  
  21370.     # returns next n pretokens if they exist
  21371.     # returns undef's if hits eof without seeing any pretokens
  21372.     my $max_pretokens = shift;
  21373.     my $line;
  21374.     my $i = 0;
  21375.     my ( $rpre_tokens, $rmap, $rpre_types );
  21376.  
  21377.     while ( $line = $tokenizer_self->{_line_buffer_object}->peek_ahead( $i++ ) )
  21378.     {
  21379.         $line =~ s/^\s*//;    # trim leading blanks
  21380.         next if ( length($line) <= 0 );    # skip blank
  21381.         next if ( $line =~ /^#/ );         # skip comment
  21382.         ( $rpre_tokens, $rmap, $rpre_types ) =
  21383.           pre_tokenize( $line, $max_pretokens );
  21384.         last;
  21385.     }
  21386.     return ( $rpre_tokens, $rpre_types );
  21387. }
  21388.  
  21389. # look ahead for next non-blank, non-comment line of code
  21390. sub peek_ahead_for_nonblank_token {
  21391.     my $rtokens = shift;
  21392.     my $line;
  21393.     my $i = 0;
  21394.  
  21395.     while ( $line = $tokenizer_self->{_line_buffer_object}->peek_ahead( $i++ ) )
  21396.     {
  21397.         $line =~ s/^\s*//;    # trim leading blanks
  21398.         next if ( length($line) <= 0 );    # skip blank
  21399.         next if ( $line =~ /^#/ );         # skip comment
  21400.         my ( $rtok, $rmap, $rtype ) =
  21401.           pre_tokenize( $line, 2 );        # only need 2 pre-tokens
  21402.         my $j = $max_token_index + 1;
  21403.         my $tok;
  21404.  
  21405.         foreach $tok (@$rtok) {
  21406.             last if ( $tok =~ "\n" );
  21407.             $$rtokens[ ++$j ] = $tok;
  21408.         }
  21409.         last;
  21410.     }
  21411.     return $rtokens;
  21412. }
  21413.  
  21414. sub pre_tokenize {
  21415.  
  21416.     # Break a string, $str, into a sequence of preliminary tokens.  We
  21417.     # are interested in these types of tokens:
  21418.     #   words       (type='w'),            example: 'max_tokens_wanted'
  21419.     #   digits      (type = 'd'),          example: '0755'
  21420.     #   whitespace  (type = 'b'),          example: '   '
  21421.     #   any other single character (i.e. punct; type = the character itself).
  21422.     # We cannot do better than this yet because we might be in a quoted
  21423.     # string or pattern.  Caller sets $max_tokens_wanted to 0 to get all
  21424.     # tokens.
  21425.     my ( $str, $max_tokens_wanted ) = @_;
  21426.  
  21427.     # we return references to these 3 arrays:
  21428.     my @tokens    = ();     # array of the tokens themselves
  21429.     my @token_map = (0);    # string position of start of each token
  21430.     my @type      = ();     # 'b'=whitespace, 'd'=digits, 'w'=alpha, or punct
  21431.  
  21432.     do {
  21433.  
  21434.         # whitespace
  21435.         if ( $str =~ /\G(\s+)/gc ) { push @type, 'b'; }
  21436.  
  21437.         # numbers
  21438.         # note that this must come before words!
  21439.         elsif ( $str =~ /\G(\d+)/gc ) { push @type, 'd'; }
  21440.  
  21441.         # words
  21442.         elsif ( $str =~ /\G(\w+)/gc ) { push @type, 'w'; }
  21443.  
  21444.         # single-character punctuation
  21445.         elsif ( $str =~ /\G(\W)/gc ) { push @type, $1; }
  21446.  
  21447.         # that's all..
  21448.         else {
  21449.             return ( \@tokens, \@token_map, \@type );
  21450.         }
  21451.  
  21452.         push @tokens,    $1;
  21453.         push @token_map, pos($str);
  21454.  
  21455.     } while ( --$max_tokens_wanted != 0 );
  21456.  
  21457.     return ( \@tokens, \@token_map, \@type );
  21458. }
  21459.  
  21460. sub show_tokens {
  21461.  
  21462.     # this is an old debug routine
  21463.     my ( $rtokens, $rtoken_map ) = @_;
  21464.     my $num = scalar(@$rtokens);
  21465.     my $i;
  21466.  
  21467.     for ( $i = 0 ; $i < $num ; $i++ ) {
  21468.         my $len = length( $$rtokens[$i] );
  21469.         print "$i:$len:$$rtoken_map[$i]:$$rtokens[$i]:\n";
  21470.     }
  21471. }
  21472.  
  21473. sub find_angle_operator_termination {
  21474.  
  21475.     # We are looking at a '<' and want to know if it is an angle operator.
  21476.     # We are to return:
  21477.     #   $i = pretoken index of ending '>' if found, current $i otherwise
  21478.     #   $type = 'Q' if found, '>' otherwise
  21479.     my ( $input_line, $i_beg, $rtoken_map, $expecting ) = @_;
  21480.     my $i    = $i_beg;
  21481.     my $type = '<';
  21482.     pos($input_line) = 1 + $$rtoken_map[$i];
  21483.  
  21484.     my $filter;
  21485.  
  21486.     # we just have to find the next '>' if a term is expected
  21487.     if ( $expecting == TERM ) { $filter = '[\>]' }
  21488.  
  21489.     # we have to guess if we don't know what is expected
  21490.     elsif ( $expecting == UNKNOWN ) { $filter = '[\>\;\=\#\|\<]' }
  21491.  
  21492.     # shouldn't happen - we shouldn't be here if operator is expected
  21493.     else { warning("Program Bug in find_angle_operator_termination\n") }
  21494.  
  21495.     # To illustrate what we might be looking at, in case we are
  21496.     # guessing, here are some examples of valid angle operators
  21497.     # (or file globs):
  21498.     #  <tmp_imp/*>
  21499.     #  <FH>
  21500.     #  <$fh>
  21501.     #  <*.c *.h>
  21502.     #  <_>
  21503.     #  <jskdfjskdfj* op/* jskdjfjkosvk*> ( glob.t)
  21504.     #  <${PREFIX}*img*.$IMAGE_TYPE>
  21505.     #  <img*.$IMAGE_TYPE>
  21506.     #  <Timg*.$IMAGE_TYPE>
  21507.     #  <$LATEX2HTMLVERSIONS${dd}html[1-9].[0-9].pl>
  21508.     #
  21509.     # Here are some examples of lines which do not have angle operators:
  21510.     #  return undef unless $self->[2]++ < $#{$self->[1]};
  21511.     #  < 2  || @$t >
  21512.     #
  21513.     # the following line from dlister.pl caused trouble:
  21514.     #  print'~'x79,"\n",$D<1024?"0.$D":$D>>10,"K, $C files\n\n\n";
  21515.     #
  21516.     # If the '<' starts an angle operator, it must end on this line and
  21517.     # it must not have certain characters like ';' and '=' in it.  I use
  21518.     # this to limit the testing.  This filter should be improved if
  21519.     # possible.
  21520.  
  21521.     if ( $input_line =~ /($filter)/g ) {
  21522.  
  21523.         if ( $1 eq '>' ) {
  21524.  
  21525.             # We MAY have found an angle operator termination if we get
  21526.             # here, but we need to do more to be sure we haven't been
  21527.             # fooled.
  21528.             my $pos = pos($input_line);
  21529.  
  21530.             my $pos_beg = $$rtoken_map[$i];
  21531.             my $str     = substr( $input_line, $pos_beg, ( $pos - $pos_beg ) );
  21532.  
  21533.             ######################################debug#####
  21534.             #write_diagnostics( "ANGLE? :$str\n");
  21535.             #print "ANGLE: found $1 at pos=$pos\n";
  21536.             ######################################debug#####
  21537.             $type = 'Q';
  21538.             my $error;
  21539.             ( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map );
  21540.  
  21541.             # It may be possible that a quote ends midway in a pretoken.
  21542.             # If this happens, it may be necessary to split the pretoken.
  21543.             if ($error) {
  21544.                 warning(
  21545.                     "Possible tokinization error..please check this line\n");
  21546.                 report_possible_bug();
  21547.             }
  21548.  
  21549.             # Now let's see where we stand....
  21550.             # OK if math op not possible
  21551.             if ( $expecting == TERM ) {
  21552.             }
  21553.  
  21554.             # OK if there are no more than 2 pre-tokens inside
  21555.             # (not possible to write 2 token math between < and >)
  21556.             # This catches most common cases
  21557.             elsif ( $i <= $i_beg + 3 ) {
  21558.                 write_diagnostics("ANGLE(1 or 2 tokens): $str\n");
  21559.             }
  21560.  
  21561.             # Not sure..
  21562.             else {
  21563.  
  21564.                 # Let's try a Brace Test: any braces inside must balance
  21565.                 my $br = 0;
  21566.                 while ( $str =~ /\{/g ) { $br++ }
  21567.                 while ( $str =~ /\}/g ) { $br-- }
  21568.                 my $sb = 0;
  21569.                 while ( $str =~ /\[/g ) { $sb++ }
  21570.                 while ( $str =~ /\]/g ) { $sb-- }
  21571.                 my $pr = 0;
  21572.                 while ( $str =~ /\(/g ) { $pr++ }
  21573.                 while ( $str =~ /\)/g ) { $pr-- }
  21574.  
  21575.                 # if braces do not balance - not angle operator
  21576.                 if ( $br || $sb || $pr ) {
  21577.                     $i    = $i_beg;
  21578.                     $type = '<';
  21579.                     write_diagnostics(
  21580.                         "NOT ANGLE (BRACE={$br ($pr [$sb ):$str\n");
  21581.                 }
  21582.  
  21583.                 # we should keep doing more checks here...to be continued
  21584.                 # Tentatively accepting this as a valid angle operator.
  21585.                 # There are lots more things that can be checked.
  21586.                 else {
  21587.                     write_diagnostics(
  21588.                         "ANGLE-Guessing yes: $str expecting=$expecting\n");
  21589.                     write_logfile_entry("Guessing angle operator here: $str\n");
  21590.                 }
  21591.             }
  21592.         }
  21593.  
  21594.         # didn't find ending >
  21595.         else {
  21596.             if ( $expecting == TERM ) {
  21597.                 warning("No ending > for angle operator\n");
  21598.             }
  21599.         }
  21600.     }
  21601.     return ( $i, $type );
  21602. }
  21603.  
  21604. sub inverse_pretoken_map {
  21605.  
  21606.     # Starting with the current pre_token index $i, scan forward until
  21607.     # finding the index of the next pre_token whose position is $pos.
  21608.     my ( $i, $pos, $rtoken_map ) = @_;
  21609.     my $error = 0;
  21610.  
  21611.     while ( ++$i <= $max_token_index ) {
  21612.  
  21613.         if ( $pos <= $$rtoken_map[$i] ) {
  21614.  
  21615.             # Let the calling routine handle errors in which we do not
  21616.             # land on a pre-token boundary.  It can happen by running
  21617.             # perltidy on some non-perl scripts, for example.
  21618.             if ( $pos < $$rtoken_map[$i] ) { $error = 1 }
  21619.             $i--;
  21620.             last;
  21621.         }
  21622.     }
  21623.     return ( $i, $error );
  21624. }
  21625.  
  21626. sub guess_if_pattern_or_conditional {
  21627.  
  21628.     # this routine is called when we have encountered a ? following an
  21629.     # unknown bareword, and we must decide if it starts a pattern or not
  21630.     # input parameters:
  21631.     #   $i - token index of the ? starting possible pattern
  21632.     # output parameters:
  21633.     #   $is_pattern = 0 if probably not pattern,  =1 if probably a pattern
  21634.     #   msg = a warning or diagnostic message
  21635.     my ( $i, $rtokens, $rtoken_map ) = @_;
  21636.     my $is_pattern = 0;
  21637.     my $msg        = "guessing that ? after $last_nonblank_token starts a ";
  21638.  
  21639.     if ( $i >= $max_token_index ) {
  21640.         $msg .= "conditional (no end to pattern found on the line)\n";
  21641.     }
  21642.     else {
  21643.         my $ibeg = $i;
  21644.         $i = $ibeg + 1;
  21645.         my $next_token = $$rtokens[$i];    # first token after ?
  21646.  
  21647.         # look for a possible ending ? on this line..
  21648.         my $in_quote        = 1;
  21649.         my $quote_depth     = 0;
  21650.         my $quote_character = '';
  21651.         my $quote_pos       = 0;
  21652.         ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth ) =
  21653.           follow_quoted_string( $ibeg, $in_quote, $rtokens, $quote_character,
  21654.             $quote_pos, $quote_depth );
  21655.  
  21656.         if ($in_quote) {
  21657.  
  21658.             # we didn't find an ending ? on this line,
  21659.             # so we bias towards conditional
  21660.             $is_pattern = 0;
  21661.             $msg .= "conditional (no ending ? on this line)\n";
  21662.  
  21663.             # we found an ending ?, so we bias towards a pattern
  21664.         }
  21665.         else {
  21666.  
  21667.             if ( pattern_expected( $i, $rtokens ) >= 0 ) {
  21668.                 $is_pattern = 1;
  21669.                 $msg .= "pattern (found ending ? and pattern expected)\n";
  21670.             }
  21671.             else {
  21672.                 $msg .= "pattern (uncertain, but found ending ?)\n";
  21673.             }
  21674.         }
  21675.     }
  21676.     return ( $is_pattern, $msg );
  21677. }
  21678.  
  21679. sub guess_if_pattern_or_division {
  21680.  
  21681.     # this routine is called when we have encountered a / following an
  21682.     # unknown bareword, and we must decide if it starts a pattern or is a
  21683.     # division
  21684.     # input parameters:
  21685.     #   $i - token index of the / starting possible pattern
  21686.     # output parameters:
  21687.     #   $is_pattern = 0 if probably division,  =1 if probably a pattern
  21688.     #   msg = a warning or diagnostic message
  21689.     my ( $i, $rtokens, $rtoken_map ) = @_;
  21690.     my $is_pattern = 0;
  21691.     my $msg        = "guessing that / after $last_nonblank_token starts a ";
  21692.  
  21693.     if ( $i >= $max_token_index ) {
  21694.         "division (no end to pattern found on the line)\n";
  21695.     }
  21696.     else {
  21697.         my $ibeg = $i;
  21698.         my $divide_expected = numerator_expected( $i, $rtokens );
  21699.         $i = $ibeg + 1;
  21700.         my $next_token = $$rtokens[$i];    # first token after slash
  21701.  
  21702.         # look for a possible ending / on this line..
  21703.         my $in_quote        = 1;
  21704.         my $quote_depth     = 0;
  21705.         my $quote_character = '';
  21706.         my $quote_pos       = 0;
  21707.         ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth ) =
  21708.           follow_quoted_string( $ibeg, $in_quote, $rtokens, $quote_character,
  21709.             $quote_pos, $quote_depth );
  21710.  
  21711.         if ($in_quote) {
  21712.  
  21713.             # we didn't find an ending / on this line,
  21714.             # so we bias towards division
  21715.             if ( $divide_expected >= 0 ) {
  21716.                 $is_pattern = 0;
  21717.                 $msg .= "division (no ending / on this line)\n";
  21718.             }
  21719.             else {
  21720.                 $msg        = "multi-line pattern (division not possible)\n";
  21721.                 $is_pattern = 1;
  21722.             }
  21723.  
  21724.         }
  21725.  
  21726.         # we found an ending /, so we bias towards a pattern
  21727.         else {
  21728.  
  21729.             if ( pattern_expected( $i, $rtokens ) >= 0 ) {
  21730.  
  21731.                 if ( $divide_expected >= 0 ) {
  21732.  
  21733.                     if ( $i - $ibeg > 60 ) {
  21734.                         $msg .= "division (matching / too distant)\n";
  21735.                         $is_pattern = 0;
  21736.                     }
  21737.                     else {
  21738.                         $msg .= "pattern (but division possible too)\n";
  21739.                         $is_pattern = 1;
  21740.                     }
  21741.                 }
  21742.                 else {
  21743.                     $is_pattern = 1;
  21744.                     $msg .= "pattern (division not possible)\n";
  21745.                 }
  21746.             }
  21747.             else {
  21748.  
  21749.                 if ( $divide_expected >= 0 ) {
  21750.                     $is_pattern = 0;
  21751.                     $msg .= "division (pattern not possible)\n";
  21752.                 }
  21753.                 else {
  21754.                     $is_pattern = 1;
  21755.                     $msg .=
  21756.                       "pattern (uncertain, but division would not work here)\n";
  21757.                 }
  21758.             }
  21759.         }
  21760.     }
  21761.     return ( $is_pattern, $msg );
  21762. }
  21763.  
  21764. sub find_here_doc {
  21765.  
  21766.     # find the target of a here document, if any
  21767.     # input parameters:
  21768.     #   $i - token index of the second < of <<
  21769.     #   ($i must be less than the last token index if this is called)
  21770.     # output parameters:
  21771.     #   $found_target = 0 didn't find target; =1 found target
  21772.     #   HERE_TARGET - the target string (may be empty string)
  21773.     #   $i - unchanged if not here doc,
  21774.     #    or index of the last token of the here target
  21775.     my ( $expecting, $i, $rtokens, $rtoken_map ) = @_;
  21776.     my $ibeg                 = $i;
  21777.     my $found_target         = 0;
  21778.     my $here_doc_target      = '';
  21779.     my $here_quote_character = '';
  21780.     my ( $next_nonblank_token, $i_next_nonblank, $next_token );
  21781.     $next_token = $$rtokens[ $i + 1 ];
  21782.  
  21783.     # perl allows a backslash before the target string (heredoc.t)
  21784.     my $backslash = 0;
  21785.     if ( $next_token eq '\\' ) {
  21786.         $backslash  = 1;
  21787.         $next_token = $$rtokens[ $i + 2 ];
  21788.     }
  21789.  
  21790.     ( $next_nonblank_token, $i_next_nonblank ) =
  21791.       find_next_nonblank_token_on_this_line( $i, $rtokens );
  21792.  
  21793.     if ( $next_nonblank_token =~ /[\'\"\`]/ ) {
  21794.  
  21795.         my $in_quote    = 1;
  21796.         my $quote_depth = 0;
  21797.         my $quote_pos   = 0;
  21798.  
  21799.         ( $i, $in_quote, $here_quote_character, $quote_pos, $quote_depth ) =
  21800.           follow_quoted_string( $i_next_nonblank, $in_quote, $rtokens,
  21801.             $here_quote_character, $quote_pos, $quote_depth );
  21802.  
  21803.         if ($in_quote) {    # didn't find end of quote, so no target found
  21804.             $i = $ibeg;
  21805.         }
  21806.         else {              # found ending quote
  21807.             my $j;
  21808.             $found_target = 1;
  21809.  
  21810.             my $tokj;
  21811.             for ( $j = $i_next_nonblank + 1 ; $j < $i ; $j++ ) {
  21812.                 $tokj = $$rtokens[$j];
  21813.  
  21814.                 # we have to remove any backslash before the quote character
  21815.                 # so that the here-doc-target exactly matches this string
  21816.                 next
  21817.                   if ( $tokj eq "\\"
  21818.                     && $j < $i - 1
  21819.                     && $$rtokens[ $j + 1 ] eq $here_quote_character );
  21820.                 $here_doc_target .= $tokj;
  21821.             }
  21822.         }
  21823.     }
  21824.  
  21825.     elsif ( ( $next_token =~ /^\s*$/ ) and ( $expecting == TERM ) ) {
  21826.         $found_target = 1;
  21827.         write_logfile_entry(
  21828.             "found blank here-target after <<; suggest using \"\"\n");
  21829.         $i = $ibeg;
  21830.     }
  21831.     elsif ( $next_token =~ /^\w/ ) {    # simple bareword or integer after <<
  21832.  
  21833.         my $here_doc_expected;
  21834.         if ( $expecting == UNKNOWN ) {
  21835.             $here_doc_expected = guess_if_here_doc($next_token);
  21836.         }
  21837.         else {
  21838.             $here_doc_expected = 1;
  21839.         }
  21840.  
  21841.         if ($here_doc_expected) {
  21842.             $found_target    = 1;
  21843.             $here_doc_target = $next_token;
  21844.             $i               = $ibeg + 1;
  21845.         }
  21846.  
  21847.     }
  21848.     else {
  21849.  
  21850.         if ( $expecting == TERM ) {
  21851.             $found_target = 1;
  21852.             write_logfile_entry("Note: bare here-doc operator <<\n");
  21853.         }
  21854.         else {
  21855.             $i = $ibeg;
  21856.         }
  21857.     }
  21858.  
  21859.     # patch to neglect any prepended backslash
  21860.     if ( $found_target && $backslash ) { $i++ }
  21861.  
  21862.     return ( $found_target, $here_doc_target, $here_quote_character, $i );
  21863. }
  21864.  
  21865. # try to resolve here-doc vs. shift by looking ahead for
  21866. # non-code or the end token (currently only looks for end token)
  21867. # returns 1 if it is probably a here doc, 0 if not
  21868. sub guess_if_here_doc {
  21869.  
  21870.     # This is how many lines we will search for a target as part of the
  21871.     # guessing strategy.  It is a constant because there is probably
  21872.     # little reason to change it.
  21873.     use constant HERE_DOC_WINDOW => 40;
  21874.  
  21875.     my $next_token        = shift;
  21876.     my $here_doc_expected = 0;
  21877.     my $line;
  21878.     my $k   = 0;
  21879.     my $msg = "checking <<";
  21880.  
  21881.     while ( $line = $tokenizer_self->{_line_buffer_object}->peek_ahead( $k++ ) )
  21882.     {
  21883.         chomp $line;
  21884.  
  21885.         if ( $line =~ /^$next_token$/ ) {
  21886.             $msg .= " -- found target $next_token ahead $k lines\n";
  21887.             $here_doc_expected = 1;    # got it
  21888.             last;
  21889.         }
  21890.         last if ( $k >= HERE_DOC_WINDOW );
  21891.     }
  21892.  
  21893.     unless ($here_doc_expected) {
  21894.  
  21895.         if ( !defined($line) ) {
  21896.             $here_doc_expected = -1;    # hit eof without seeing target
  21897.             $msg .= " -- must be shift; target $next_token not in file\n";
  21898.  
  21899.         }
  21900.         else {                          # still unsure..taking a wild guess
  21901.  
  21902.             if ( !$is_constant{$current_package}{$next_token} ) {
  21903.                 $here_doc_expected = 1;
  21904.                 $msg .=
  21905.                   " -- guessing it's a here-doc ($next_token not a constant)\n";
  21906.             }
  21907.             else {
  21908.                 $msg .=
  21909.                   " -- guessing it's a shift ($next_token is a constant)\n";
  21910.             }
  21911.         }
  21912.     }
  21913.     write_logfile_entry($msg);
  21914.     return $here_doc_expected;
  21915. }
  21916.  
  21917. sub do_quote {
  21918.  
  21919.     # follow (or continue following) quoted string or pattern
  21920.     # $in_quote return code:
  21921.     #   0 - ok, found end
  21922.     #   1 - still must find end of quote whose target is $quote_character
  21923.     #   2 - still looking for end of first of two quotes
  21924.     my ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth, $rtokens,
  21925.         $rtoken_map )
  21926.       = @_;
  21927.  
  21928.     if ( $in_quote == 2 ) {    # two quotes/patterns to follow
  21929.         my $ibeg = $i;
  21930.         ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth ) =
  21931.           follow_quoted_string( $i, $in_quote, $rtokens, $quote_character,
  21932.             $quote_pos, $quote_depth );
  21933.  
  21934.         if ( $in_quote == 1 ) {
  21935.             if ( $quote_character =~ /[\{\[\<\(]/ ) { $i++; }
  21936.             $quote_character = '';
  21937.         }
  21938.     }
  21939.  
  21940.     if ( $in_quote == 1 ) {    # one (more) quote to follow
  21941.         my $ibeg = $i;
  21942.         ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth ) =
  21943.           follow_quoted_string( $ibeg, $in_quote, $rtokens, $quote_character,
  21944.             $quote_pos, $quote_depth );
  21945.     }
  21946.     return ( $i, $in_quote, $quote_character, $quote_pos, $quote_depth );
  21947. }
  21948.  
  21949. sub scan_number_do {
  21950.  
  21951.     #  scan a number in any of the formats that Perl accepts
  21952.     #  Underbars (_) are allowed in decimal numbers.
  21953.     #  input parameters -
  21954.     #      $input_line  - the string to scan
  21955.     #      $i           - pre_token index to start scanning
  21956.     #    $rtoken_map    - reference to the pre_token map giving starting
  21957.     #                    character position in $input_line of token $i
  21958.     #  output parameters -
  21959.     #    $i            - last pre_token index of the number just scanned
  21960.     #    number        - the number (characters); or undef if not a number
  21961.  
  21962.     my ( $input_line, $i, $rtoken_map, $input_type ) = @_;
  21963.     my $pos_beg = $$rtoken_map[$i];
  21964.     my $pos;
  21965.     my $i_begin = $i;
  21966.     my $number  = undef;
  21967.     my $type    = $input_type;
  21968.  
  21969.     my $first_char = substr( $input_line, $pos_beg, 1 );
  21970.  
  21971.     # Look for bad starting characters; Shouldn't happen..
  21972.     if ( $first_char !~ /[\d\.\+\-Ee]/ ) {
  21973.         warning("Program bug - scan_number given character $first_char\n");
  21974.         report_definite_bug();
  21975.         return ( $i, $type, $number );
  21976.     }
  21977.  
  21978.     # handle v-string without leading 'v' character ('Two Dot' rule)
  21979.     # (vstring.t)
  21980.     pos($input_line) = $pos_beg;
  21981.     if ( $input_line =~ /\G((\d+)?\.\d+(\.\d+)+)/g ) {
  21982.         $pos = pos($input_line);
  21983.         my $numc = $pos - $pos_beg;
  21984.         $number = substr( $input_line, $pos_beg, $numc );
  21985.         $type = 'v';
  21986.         unless ($saw_v_string) { report_v_string($number) }
  21987.     }
  21988.  
  21989.     # handle octal, hex, binary
  21990.     if ( !defined($number) ) {
  21991.         pos($input_line) = $pos_beg;
  21992.         if ( $input_line =~ /\G[+-]?0((x[0-9a-fA-F_]+)|([0-7_]+)|(b[01_]+))/g )
  21993.         {
  21994.             $pos = pos($input_line);
  21995.             my $numc = $pos - $pos_beg;
  21996.             $number = substr( $input_line, $pos_beg, $numc );
  21997.             $type = 'n';
  21998.         }
  21999.     }
  22000.  
  22001.     # handle decimal
  22002.     if ( !defined($number) ) {
  22003.         pos($input_line) = $pos_beg;
  22004.  
  22005.         if ( $input_line =~ /\G([+-]?[\d_]*(\.[\d_]*)?([Ee][+-]?(\d+))?)/g ) {
  22006.             $pos = pos($input_line);
  22007.  
  22008.             # watch out for things like 0..40 which would give 0. by this;
  22009.             if (   ( substr( $input_line, $pos - 1, 1 ) eq '.' )
  22010.                 && ( substr( $input_line, $pos, 1 ) eq '.' ) )
  22011.             {
  22012.                 $pos--;
  22013.             }
  22014.             my $numc = $pos - $pos_beg;
  22015.             $number = substr( $input_line, $pos_beg, $numc );
  22016.             $type = 'n';
  22017.         }
  22018.     }
  22019.  
  22020.     # filter out non-numbers like e + - . e2  .e3 +e6
  22021.     # the rule: at least one digit, and any 'e' must be preceded by a digit
  22022.     if (
  22023.         $number !~ /\d/    # no digits
  22024.         || (   $number =~ /^(.*)[eE]/
  22025.             && $1 !~ /\d/ )    # or no digits before the 'e'
  22026.       )
  22027.     {
  22028.         $number = undef;
  22029.         $type   = $input_type;
  22030.         return ( $i, $type, $number );
  22031.     }
  22032.  
  22033.     # Found a number; now we must convert back from character position
  22034.     # to pre_token index. An error here implies user syntax error.
  22035.     # An example would be an invalid octal number like '009'.
  22036.     my $error;
  22037.     ( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map );
  22038.     if ($error) { warning("Possibly invalid number\n") }
  22039.  
  22040.     return ( $i, $type, $number );
  22041. }
  22042.  
  22043. sub scan_bare_identifier_do {
  22044.  
  22045.     # this routine is called to scan a token starting with an alphanumeric
  22046.     # variable or package separator, :: or '.
  22047.  
  22048.     my ( $input_line, $i, $tok, $type, $prototype, $rtoken_map ) = @_;
  22049.     my $i_begin = $i;
  22050.     my $package = undef;
  22051.  
  22052.     my $i_beg = $i;
  22053.  
  22054.     # we have to back up one pretoken at a :: since each : is one pretoken
  22055.     if ( $tok eq '::' ) { $i_beg-- }
  22056.     if ( $tok eq '->' ) { $i_beg-- }
  22057.     my $pos_beg = $$rtoken_map[$i_beg];
  22058.     pos($input_line) = $pos_beg;
  22059.  
  22060.     if ( $input_line =~ m/\G\s*((?:\w*(?:'|::)))*(?:->)?(\w+)/gc ) {
  22061.  
  22062.         my $pos  = pos($input_line);
  22063.         my $numc = $pos - $pos_beg;
  22064.         $tok = substr( $input_line, $pos_beg, $numc );
  22065.  
  22066.         # type 'w' includes anything without leading type info
  22067.         # ($,%,@,*) including something like abc::def::ghi
  22068.         $type = 'w';
  22069.  
  22070.         if ( defined($1) ) {
  22071.             $package = $1;
  22072.             $package =~ s/\'/::/g;
  22073.             if ( $package =~ /^\:/ ) { $package = 'main' . $package }
  22074.             $package =~ s/::$//;
  22075.         }
  22076.         else {
  22077.             $package = $current_package;
  22078.  
  22079.             if ( $is_keyword{$tok} ) {
  22080.                 $type = 'k';
  22081.             }
  22082.         }
  22083.         my $sub_name = $2;
  22084.  
  22085.         # if it is a bareword..
  22086.         if ( $type eq 'w' ) {
  22087.  
  22088.             # check for v-string with leading 'v' type character
  22089.             # (This seems to have presidence over filehandle, type 'Y')
  22090.             if ( $tok =~ /^v\d+$/ ) {
  22091.  
  22092.                 # we only have the first part - something like 'v101' -
  22093.                 # look for more
  22094.                 if ( $input_line =~ m/\G(\.\d+)+/gc ) {
  22095.                     $pos  = pos($input_line);
  22096.                     $numc = $pos - $pos_beg;
  22097.                     $tok  = substr( $input_line, $pos_beg, $numc );
  22098.                 }
  22099.                 $type = 'v';
  22100.  
  22101.                 # warn if this version can't handle v-strings
  22102.                 unless ($saw_v_string) { report_v_string($tok) }
  22103.             }
  22104.  
  22105.             elsif ( $is_constant{$package}{$sub_name} ) {
  22106.                 $type = 'C';
  22107.             }
  22108.  
  22109.             # bareword after sort has implied empty prototype; for example:
  22110.             # @sorted = sort numerically ( 53, 29, 11, 32, 7 );
  22111.             # This has priority over whatever the user has specified.
  22112.             elsif ($last_nonblank_token eq 'sort'
  22113.                 && $last_nonblank_type eq 'k' )
  22114.             {
  22115.                 $type = 'Z';
  22116.             }
  22117.  
  22118.             # Note: strangely, perl does not seem to really let you create
  22119.             # functions which act like eval and do, in the sense that eval
  22120.             # and do may have operators following the final }, but any operators
  22121.             # that you create with prototype (&) apparently do not allow
  22122.             # trailing operators, only terms.  This seems strange.
  22123.             # If this ever changes, here is the update
  22124.             # to make perltidy behave accordingly:
  22125.  
  22126.             # elsif ( $is_block_function{$package}{$tok} ) {
  22127.             #    $tok='eval'; # patch to do braces like eval  - doesn't work
  22128.             #    $type = 'k';
  22129.             #}
  22130.             # FIXME: This could become a separate type to allow for different
  22131.             # future behavior:
  22132.             elsif ( $is_block_function{$package}{$sub_name} ) {
  22133.                 $type = 'G';
  22134.             }
  22135.  
  22136.             elsif ( $is_block_list_function{$package}{$sub_name} ) {
  22137.                 $type = 'G';
  22138.             }
  22139.             elsif ( $is_user_function{$package}{$sub_name} ) {
  22140.                 $type      = 'U';
  22141.                 $prototype = $user_function_prototype{$package}{$sub_name};
  22142.             }
  22143.  
  22144.             # check for indirect object
  22145.             elsif (
  22146.  
  22147.                 # added 2001-03-27: must not be followed immediately by '('
  22148.                 # see fhandle.t
  22149.                 ( $input_line !~ m/\G\(/gc )
  22150.  
  22151.                 # and
  22152.                 && (
  22153.  
  22154.                     # preceded by keyword like 'print', 'printf' and friends
  22155.                     $is_indirect_object_taker{$last_nonblank_token}
  22156.  
  22157.                     # or preceded by something like 'print(' or 'printf('
  22158.                     || (
  22159.                         ( $last_nonblank_token eq '(' )
  22160.                         && $is_indirect_object_taker{ $paren_type[$paren_depth]
  22161.                         }
  22162.  
  22163.                     )
  22164.                 )
  22165.               )
  22166.             {
  22167.  
  22168.                 # may not be indirect object unless followed by a space
  22169.                 if ( $input_line =~ m/\G\s+/gc ) {
  22170.                     $type = 'Y';
  22171.  
  22172.                     # Abandon Hope ...
  22173.                     # Perl's indirect object notation is a very bad
  22174.                     # thing and can cause subtle bugs, especially for
  22175.                     # beginning programmers.  And I haven't even been
  22176.                     # able to figure out a sane warning scheme which
  22177.                     # doesn't get in the way of good scripts.
  22178.  
  22179.                     # Complain if a filehandle has any lower case
  22180.                     # letters.  This is suggested good practice, but the
  22181.                     # main reason for this warning is that prior to
  22182.                     # release 20010328, perltidy incorrectly parsed a
  22183.                     # function call after a print/printf, with the
  22184.                     # result that a space got added before the opening
  22185.                     # paren, thereby converting the function name to a
  22186.                     # filehandle according to perl's weird rules.  This
  22187.                     # will not usually generate a syntax error, so this
  22188.                     # is a potentially serious bug.  By warning
  22189.                     # of filehandles with any lower case letters,
  22190.                     # followed by opening parens, we will help the user
  22191.                     # find almost all of these older errors.
  22192.                     # use 'sub_name' because something like
  22193.                     # main::MYHANDLE is ok for filehandle
  22194.                     if ( $sub_name =~ /[a-z]/ ) {
  22195.  
  22196.                         # could be bug caused by older perltidy if
  22197.                         # followed by '('
  22198.                         if ( $input_line =~ m/\G\s*\(/gc ) {
  22199.                             complain(
  22200. "Caution: unknown word '$tok' in indirect object slot\n"
  22201.                             );
  22202.                         }
  22203.                     }
  22204.                 }
  22205.  
  22206.                 # bareword not followed by a space -- may not be filehandle
  22207.                 # (may be function call defined in a 'use' statement)
  22208.                 else {
  22209.                     $type = 'Z';
  22210.                 }
  22211.             }
  22212.         }
  22213.  
  22214.         # Now we must convert back from character position
  22215.         # to pre_token index.
  22216.         # I don't think an error flag can occur here ..but who knows
  22217.         my $error;
  22218.         ( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map );
  22219.         if ($error) {
  22220.             warning("scan_bare_identifier: Possibly invalid tokenization\n");
  22221.         }
  22222.     }
  22223.  
  22224.     # no match but line not blank - could be syntax error
  22225.     # perl will take '::' alone without complaint
  22226.     else {
  22227.         $type = 'w';
  22228.  
  22229.         # change this warning to log message if it becomes annoying
  22230.         warning("didn't find identifier after leading ::\n");
  22231.     }
  22232.     return ( $i, $tok, $type, $prototype );
  22233. }
  22234.  
  22235. sub scan_id_do {
  22236.  
  22237.     # This is the new scanner and will eventually replace scan_identifier.
  22238.     # Only type 'sub' and 'package' are implemented.
  22239.     # Token types $ * % @ & -> are not yet implemented.
  22240.     #
  22241.     # Scan identifier following a type token.
  22242.     # The type of call depends on $id_scan_state: $id_scan_state = ''
  22243.     # for starting call, in which case $tok must be the token defining
  22244.     # the type.
  22245.     #
  22246.     # If the type token is the last nonblank token on the line, a value
  22247.     # of $id_scan_state = $tok is returned, indicating that further
  22248.     # calls must be made to get the identifier.  If the type token is
  22249.     # not the last nonblank token on the line, the identifier is
  22250.     # scanned and handled and a value of '' is returned.
  22251.  
  22252.     my ( $input_line, $i, $tok, $rtokens, $rtoken_map, $id_scan_state ) = @_;
  22253.     my $type = '';
  22254.     my ( $i_beg, $pos_beg );
  22255.  
  22256.     #print "NSCAN:entering i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
  22257.     #my ($a,$b,$c) = caller;
  22258.     #print "NSCAN: scan_id called with tok=$tok $a $b $c\n";
  22259.  
  22260.     # on re-entry, start scanning at first token on the line
  22261.     if ($id_scan_state) {
  22262.         $i_beg = $i;
  22263.         $type  = '';
  22264.     }
  22265.  
  22266.     # on initial entry, start scanning just after type token
  22267.     else {
  22268.         $i_beg         = $i + 1;
  22269.         $id_scan_state = $tok;
  22270.         $type          = 't';
  22271.     }
  22272.  
  22273.     # find $i_beg = index of next nonblank token,
  22274.     # and handle empty lines
  22275.     my $blank_line          = 0;
  22276.     my $next_nonblank_token = $$rtokens[$i_beg];
  22277.     if ( $i_beg > $max_token_index ) {
  22278.         $blank_line = 1;
  22279.     }
  22280.     else {
  22281.  
  22282.         # only a '#' immediately after a '$' is not a comment
  22283.         if ( $next_nonblank_token eq '#' ) {
  22284.             unless ( $tok eq '$' ) {
  22285.                 $blank_line = 1;
  22286.             }
  22287.         }
  22288.  
  22289.         if ( $next_nonblank_token =~ /^\s/ ) {
  22290.             ( $next_nonblank_token, $i_beg ) =
  22291.               find_next_nonblank_token_on_this_line( $i_beg, $rtokens );
  22292.             if ( $next_nonblank_token =~ /(^#|^\s*$)/ ) {
  22293.                 $blank_line = 1;
  22294.             }
  22295.         }
  22296.     }
  22297.  
  22298.     # handle non-blank line; identifier, if any, must follow
  22299.     unless ($blank_line) {
  22300.  
  22301.         if ( $id_scan_state eq 'sub' ) {
  22302.             ( $i, $tok, $type, $id_scan_state ) =
  22303.               do_scan_sub( $input_line, $i, $i_beg, $tok, $type, $rtokens,
  22304.                 $rtoken_map, $id_scan_state );
  22305.         }
  22306.  
  22307.         elsif ( $id_scan_state eq 'package' ) {
  22308.             ( $i, $tok, $type ) =
  22309.               do_scan_package( $input_line, $i, $i_beg, $tok, $type, $rtokens,
  22310.                 $rtoken_map );
  22311.             $id_scan_state = '';
  22312.         }
  22313.  
  22314.         else {
  22315.             warning("invalid token in scan_id: $tok\n");
  22316.             $id_scan_state = '';
  22317.         }
  22318.     }
  22319.  
  22320.     if ( $id_scan_state && ( !defined($type) || !$type ) ) {
  22321.  
  22322.         # shouldn't happen:
  22323.         warning(
  22324. "Program bug in scan_id: undefined type but scan_state=$id_scan_state\n"
  22325.         );
  22326.         report_definite_bug();
  22327.     }
  22328.  
  22329.     TOKENIZER_DEBUG_FLAG_NSCAN && do {
  22330.         print
  22331.           "NSCAN: returns i=$i, tok=$tok, type=$type, state=$id_scan_state\n";
  22332.     };
  22333.     return ( $i, $tok, $type, $id_scan_state );
  22334. }
  22335.  
  22336. {
  22337.  
  22338.     # saved package and subnames in case prototype is on separate line
  22339.     my ( $package_saved, $subname_saved );
  22340.  
  22341.     sub do_scan_sub {
  22342.  
  22343.         # do_scan_sub parses a sub name and prototype
  22344.         # it is called with $i_beg equal to the index of the first nonblank
  22345.         # token following a 'sub' token.
  22346.  
  22347.         # TODO: add future error checks to be sure we have a valid
  22348.         # sub name.  For example, 'sub &doit' is wrong.  Also, be sure
  22349.         # a name is given if and only if a non-anonymous sub is
  22350.         # appropriate.
  22351.  
  22352.         my ( $input_line, $i, $i_beg, $tok, $type, $rtokens, $rtoken_map,
  22353.             $id_scan_state )
  22354.           = @_;
  22355.         $id_scan_state = "";    # normally we get everything in one call
  22356.         my $subname = undef;
  22357.         my $package = undef;
  22358.         my $proto   = undef;
  22359.         my $attrs   = undef;
  22360.         my $match;
  22361.  
  22362.         my $pos_beg = $$rtoken_map[$i_beg];
  22363.         pos($input_line) = $pos_beg;
  22364.  
  22365.         # sub NAME PROTO ATTRS
  22366.         if (
  22367.             $input_line =~ m/\G\s*
  22368.         ((?:\w*(?:'|::))*)  # package - something that ends in :: or '
  22369.         (\w+)               # NAME    - required
  22370.         (\s*\([^){]*\))?    # PROTO   - something in parens
  22371.         (\s*:)?             # ATTRS   - leading : of attribute list
  22372.         /gcx
  22373.           )
  22374.         {
  22375.             $match   = 1;
  22376.             $subname = $2;
  22377.             $proto   = $3;
  22378.             $attrs   = $4;
  22379.  
  22380.             $package = ( defined($1) && $1 ) ? $1 : $current_package;
  22381.             $package =~ s/\'/::/g;
  22382.             if ( $package =~ /^\:/ ) { $package = 'main' . $package }
  22383.             $package =~ s/::$//;
  22384.             my $pos  = pos($input_line);
  22385.             my $numc = $pos - $pos_beg;
  22386.             $tok = 'sub ' . substr( $input_line, $pos_beg, $numc );
  22387.             $type = 'i';
  22388.         }
  22389.  
  22390.         # Look for prototype/attributes not preceded on this line by subname;
  22391.         # This might be an anonymous sub with attributes,
  22392.         # or a prototype on a separate line from its sub name
  22393.         elsif (
  22394.             $input_line =~ m/\G(\s*\([^){]*\))?  # PROTO
  22395.             (\s*:)?                              # ATTRS leading ':'
  22396.             /gcx
  22397.             && ( $1 || $2 )
  22398.           )
  22399.         {
  22400.             $match = 1;
  22401.             $proto = $1;
  22402.             $attrs = $2;
  22403.  
  22404.             # Handle prototype on separate line from subname
  22405.             if ($subname_saved) {
  22406.                 $package = $package_saved;
  22407.                 $subname = $subname_saved;
  22408.                 $tok     = $last_nonblank_token;
  22409.             }
  22410.             $type = 'i';
  22411.         }
  22412.  
  22413.         if ($match) {
  22414.  
  22415.             # ATTRS: if there are attributes, back up and let the ':' be
  22416.             # found later by the scanner.
  22417.             my $pos = pos($input_line);
  22418.             if ($attrs) {
  22419.                 $pos -= length($attrs);
  22420.             }
  22421.  
  22422.             my $next_nonblank_token = $tok;
  22423.  
  22424.             # catch case of line with leading ATTR ':' after anonymous sub
  22425.             if ( $pos == $pos_beg && $tok eq ':' ) {
  22426.                 $type = 'A';
  22427.             }
  22428.  
  22429.             # We must convert back from character position
  22430.             # to pre_token index.
  22431.             else {
  22432.  
  22433.                 # I don't think an error flag can occur here ..but ?
  22434.                 my $error;
  22435.                 ( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map );
  22436.                 if ($error) { warning("Possibly invalid sub\n") }
  22437.  
  22438.                 # check for multiple definitions of a sub
  22439.                 ( $next_nonblank_token, my $i_next ) =
  22440.                   find_next_nonblank_token_on_this_line( $i, $rtokens );
  22441.             }
  22442.  
  22443.             if ( $next_nonblank_token =~ /^(\s*|#)$/ )
  22444.             {    # skip blank or side comment
  22445.                 my ( $rpre_tokens, $rpre_types ) =
  22446.                   peek_ahead_for_n_nonblank_pre_tokens(1);
  22447.                 if ( defined($rpre_tokens) && @$rpre_tokens ) {
  22448.                     $next_nonblank_token = $rpre_tokens->[0];
  22449.                 }
  22450.                 else {
  22451.                     $next_nonblank_token = '}';
  22452.                 }
  22453.             }
  22454.             $package_saved = "";
  22455.             $subname_saved = "";
  22456.             if ( $next_nonblank_token eq '{' ) {
  22457.                 if ($subname) {
  22458.                     if ( $saw_function_definition{$package}{$subname} ) {
  22459.                         my $lno = $saw_function_definition{$package}{$subname};
  22460.                         warning(
  22461. "already saw definition of 'sub $subname' in package '$package' at line $lno\n"
  22462.                         );
  22463.                     }
  22464.                     $saw_function_definition{$package}{$subname} =
  22465.                       $input_line_number;
  22466.                 }
  22467.             }
  22468.             elsif ( $next_nonblank_token eq ';' ) {
  22469.             }
  22470.             elsif ( $next_nonblank_token eq '}' ) {
  22471.             }
  22472.  
  22473.             # ATTRS - if an attribute list follows, remember the name
  22474.             # of the sub so the next opening brace can be labeled.
  22475.             # Setting 'statement_type' causes any ':'s to introduce
  22476.             # attributes.
  22477.             elsif ( $next_nonblank_token eq ':' ) {
  22478.                 $statement_type = $tok;
  22479.             }
  22480.  
  22481.             # see if PROTO follows on another line:
  22482.             elsif ( $next_nonblank_token eq '(' ) {
  22483.                 if ( $attrs || $proto ) {
  22484.                     warning(
  22485. "unexpected '(' after definition or declaration of sub '$subname'\n"
  22486.                     );
  22487.                 }
  22488.                 else {
  22489.                     $id_scan_state  = 'sub';    # we must come back to get proto
  22490.                     $statement_type = $tok;
  22491.                     $package_saved  = $package;
  22492.                     $subname_saved  = $subname;
  22493.                 }
  22494.             }
  22495.             elsif ($next_nonblank_token) {      # EOF technically ok
  22496.                 warning(
  22497. "expecting ':' or ';' or '{' after definition or declaration of sub '$subname' but saw '$next_nonblank_token'\n"
  22498.                 );
  22499.             }
  22500.             check_prototype( $proto, $package, $subname );
  22501.         }
  22502.  
  22503.         # no match but line not blank
  22504.         else {
  22505.         }
  22506.         return ( $i, $tok, $type, $id_scan_state );
  22507.     }
  22508. }
  22509.  
  22510. sub check_prototype {
  22511.     my ( $proto, $package, $subname ) = @_;
  22512.     return unless ( defined($package) && defined($subname) );
  22513.     if ( defined($proto) ) {
  22514.         $proto =~ s/^\s*\(\s*//;
  22515.         $proto =~ s/\s*\)$//;
  22516.         if ($proto) {
  22517.             $is_user_function{$package}{$subname}        = 1;
  22518.             $user_function_prototype{$package}{$subname} = "($proto)";
  22519.  
  22520.             # prototypes containing '&' must be treated specially..
  22521.             if ( $proto =~ /\&/ ) {
  22522.  
  22523.                 # right curly braces of prototypes ending in
  22524.                 # '&' may be followed by an operator
  22525.                 if ( $proto =~ /\&$/ ) {
  22526.                     $is_block_function{$package}{$subname} = 1;
  22527.                 }
  22528.  
  22529.                 # right curly braces of prototypes NOT ending in
  22530.                 # '&' may NOT be followed by an operator
  22531.                 elsif ( $proto !~ /\&$/ ) {
  22532.                     $is_block_list_function{$package}{$subname} = 1;
  22533.                 }
  22534.             }
  22535.         }
  22536.         else {
  22537.             $is_constant{$package}{$subname} = 1;
  22538.         }
  22539.     }
  22540.     else {
  22541.         $is_user_function{$package}{$subname} = 1;
  22542.     }
  22543. }
  22544.  
  22545. sub do_scan_package {
  22546.  
  22547.     # do_scan_package parses a package name
  22548.     # it is called with $i_beg equal to the index of the first nonblank
  22549.     # token following a 'package' token.
  22550.  
  22551.     my ( $input_line, $i, $i_beg, $tok, $type, $rtokens, $rtoken_map ) = @_;
  22552.     my $package = undef;
  22553.     my $pos_beg = $$rtoken_map[$i_beg];
  22554.     pos($input_line) = $pos_beg;
  22555.  
  22556.     # handle non-blank line; package name, if any, must follow
  22557.     if ( $input_line =~ m/\G\s*((?:\w*(?:'|::))*\w+)/gc ) {
  22558.         $package = $1;
  22559.         $package = ( defined($1) && $1 ) ? $1 : 'main';
  22560.         $package =~ s/\'/::/g;
  22561.         if ( $package =~ /^\:/ ) { $package = 'main' . $package }
  22562.         $package =~ s/::$//;
  22563.         my $pos  = pos($input_line);
  22564.         my $numc = $pos - $pos_beg;
  22565.         $tok  = 'package ' . substr( $input_line, $pos_beg, $numc );
  22566.         $type = 'i';
  22567.  
  22568.         # Now we must convert back from character position
  22569.         # to pre_token index.
  22570.         # I don't think an error flag can occur here ..but ?
  22571.         my $error;
  22572.         ( $i, $error ) = inverse_pretoken_map( $i, $pos, $rtoken_map );
  22573.         if ($error) { warning("Possibly invalid package\n") }
  22574.         $current_package = $package;
  22575.  
  22576.         # check for error
  22577.         my ( $next_nonblank_token, $i_next ) =
  22578.           find_next_nonblank_token( $i, $rtokens );
  22579.         if ( $next_nonblank_token !~ /^[;\}]$/ ) {
  22580.             warning(
  22581.                 "Unexpected '$next_nonblank_token' after package name '$tok'\n"
  22582.             );
  22583.         }
  22584.     }
  22585.  
  22586.     # no match but line not blank --
  22587.     # could be a label with name package, like package:  , for example.
  22588.     else {
  22589.         $type = 'k';
  22590.     }
  22591.  
  22592.     return ( $i, $tok, $type );
  22593. }
  22594.  
  22595. sub scan_identifier_do {
  22596.  
  22597.     # This routine assembles tokens into identifiers.  It maintains a
  22598.     # scan state, id_scan_state.  It updates id_scan_state based upon
  22599.     # current id_scan_state and token, and returns an updated
  22600.     # id_scan_state and the next index after the identifier.
  22601.  
  22602.     my ( $i, $id_scan_state, $identifier, $rtokens ) = @_;
  22603.     my $i_begin   = $i;
  22604.     my $type      = '';
  22605.     my $tok_begin = $$rtokens[$i_begin];
  22606.     if ( $tok_begin eq ':' ) { $tok_begin = '::' }
  22607.     my $id_scan_state_begin = $id_scan_state;
  22608.     my $identifier_begin    = $identifier;
  22609.     my $tok                 = $tok_begin;
  22610.     my $message             = "";
  22611.  
  22612.     # these flags will be used to help figure out the type:
  22613.     my $saw_alpha = ( $tok =~ /^[A-Za-z_]/ );
  22614.     my $saw_type;
  22615.  
  22616.     # allow old package separator (') except in 'use' statement
  22617.     my $allow_tick = ( $last_nonblank_token ne 'use' );
  22618.  
  22619.     # get started by defining a type and a state if necessary
  22620.     unless ($id_scan_state) {
  22621.         $context = UNKNOWN_CONTEXT;
  22622.  
  22623.         # fixup for digraph
  22624.         if ( $tok eq '>' ) {
  22625.             $tok       = '->';
  22626.             $tok_begin = $tok;
  22627.         }
  22628.         $identifier = $tok;
  22629.  
  22630.         if ( $tok eq '$' || $tok eq '*' ) {
  22631.             $id_scan_state = '$';
  22632.             $context       = SCALAR_CONTEXT;
  22633.         }
  22634.         elsif ( $tok eq '%' || $tok eq '@' ) {
  22635.             $id_scan_state = '$';
  22636.             $context       = LIST_CONTEXT;
  22637.         }
  22638.         elsif ( $tok eq '&' ) {
  22639.             $id_scan_state = '&';
  22640.         }
  22641.         elsif ( $tok eq 'sub' or $tok eq 'package' ) {
  22642.             $saw_alpha     = 0;     # 'sub' is considered type info here
  22643.             $id_scan_state = '$';
  22644.             $identifier .= ' ';     # need a space to separate sub from sub name
  22645.         }
  22646.         elsif ( $tok eq '::' ) {
  22647.             $id_scan_state = 'A';
  22648.         }
  22649.         elsif ( $tok =~ /^[A-Za-z_]/ ) {
  22650.             $id_scan_state = ':';
  22651.         }
  22652.         elsif ( $tok eq '->' ) {
  22653.             $id_scan_state = '$';
  22654.         }
  22655.         else {
  22656.  
  22657.             # shouldn't happen
  22658.             my ( $a, $b, $c ) = caller;
  22659.             warning("Program Bug: scan_identifier given bad token = $tok \n");
  22660.             warning("   called from sub $a  line: $c\n");
  22661.             report_definite_bug();
  22662.         }
  22663.         $saw_type = !$saw_alpha;
  22664.     }
  22665.     else {
  22666.         $i--;
  22667.         $saw_type = ( $tok =~ /([\$\%\@\*\&])/ );
  22668.     }
  22669.  
  22670.     # now loop to gather the identifier
  22671.     my $i_save = $i;
  22672.  
  22673.     while ( $i < $max_token_index ) {
  22674.         $i_save = $i unless ( $tok =~ /^\s*$/ );
  22675.         $tok    = $$rtokens[ ++$i ];
  22676.  
  22677.         if ( ( $tok eq ':' ) && ( $$rtokens[ $i + 1 ] eq ':' ) ) {
  22678.             $tok = '::';
  22679.             $i++;
  22680.         }
  22681.  
  22682.         if ( $id_scan_state eq '$' ) {    # starting variable name
  22683.  
  22684.             if ( $tok eq '$' ) {
  22685.  
  22686.                 $identifier .= $tok;
  22687.  
  22688.                 # we've got a punctuation variable if end of line (punct.t)
  22689.                 if ( $i == $max_token_index ) {
  22690.                     $type          = 'i';
  22691.                     $id_scan_state = '';
  22692.                     last;
  22693.                 }
  22694.             }
  22695.             elsif ( $tok =~ /^[A-Za-z_]/ ) {    # alphanumeric ..
  22696.                 $saw_alpha     = 1;
  22697.                 $id_scan_state = ':';           # now need ::
  22698.                 $identifier .= $tok;
  22699.             }
  22700.             elsif ( $tok eq "'" && $allow_tick ) {    # alphanumeric ..
  22701.                 $saw_alpha     = 1;
  22702.                 $id_scan_state = ':';                 # now need ::
  22703.                 $identifier .= $tok;
  22704.  
  22705.                 # Perl will accept leading digits in identifiers,
  22706.                 # although they may not always produce useful results.
  22707.                 # Something like $main::0 is ok.  But this also works:
  22708.                 #
  22709.                 #  sub howdy::123::bubba{ print "bubba $54321!\n" }
  22710.                 #  howdy::123::bubba();
  22711.                 #
  22712.             }
  22713.             elsif ( $tok =~ /^[0-9]/ ) {              # numeric
  22714.                 $saw_alpha     = 1;
  22715.                 $id_scan_state = ':';                 # now need ::
  22716.                 $identifier .= $tok;
  22717.             }
  22718.             elsif ( $tok eq '::' ) {
  22719.                 $id_scan_state = 'A';
  22720.                 $identifier .= $tok;
  22721.             }
  22722.             elsif ( ( $tok eq '#' ) && ( $identifier eq '$' ) ) {    # $#array
  22723.                 $identifier .= $tok;    # keep same state, a $ could follow
  22724.             }
  22725.             elsif ( $tok eq '{' ) {     # skip something like ${xxx} or ->{
  22726.                 $id_scan_state = '';
  22727.  
  22728.                 # if this is the first token of a line, any tokens for this
  22729.                 # identifier have already been accumulated
  22730.                 if ( $identifier eq '$' || $i == 0 ) { $identifier = ''; }
  22731.                 $i = $i_save;
  22732.                 last;
  22733.             }
  22734.  
  22735.             # space ok after leading $ % * & @
  22736.             elsif ( $tok =~ /^\s*$/ ) {
  22737.  
  22738.                 if ( $identifier =~ /^[\$\%\*\&\@]/ ) {
  22739.  
  22740.                     if ( length($identifier) > 1 ) {
  22741.                         $id_scan_state = '';
  22742.                         $i             = $i_save;
  22743.                         $type          = 'i';    # probably punctuation variable
  22744.                         last;
  22745.                     }
  22746.                     else {
  22747.  
  22748.                         # spaces after $'s are common, and space after @
  22749.                         # is harmless, so only complain about space
  22750.                         # after other type characters. Space after $ and
  22751.                         # @ will be removed in formatting.  Report space
  22752.                         # after % and * because they might indicate a
  22753.                         # parsing error.  In other words '% ' might be a
  22754.                         # modulo operator.  Delete this warning if it
  22755.                         # gets annoying.
  22756.                         if ( $identifier !~ /^[\@\$]$/ ) {
  22757.                             $message =
  22758.                               "Space in identifier, following $identifier\n";
  22759.                         }
  22760.                     }
  22761.                 }
  22762.  
  22763.                 # else:
  22764.                 # space after '->' is ok
  22765.             }
  22766.             elsif ( $tok eq '^' ) {
  22767.  
  22768.                 # check for some special variables like $^W
  22769.                 if ( $identifier =~ /^[\$\*\@\%]$/ ) {
  22770.                     $identifier .= $tok;
  22771.                     $id_scan_state = 'A';
  22772.                 }
  22773.                 else {
  22774.                     $id_scan_state = '';
  22775.                 }
  22776.             }
  22777.             else {    # something else
  22778.  
  22779.                 # check for various punctuation variables
  22780.                 if ( $identifier =~ /^[\$\*\@\%]$/ ) {
  22781.                     $identifier .= $tok;
  22782.                 }
  22783.  
  22784.                 elsif ( $identifier eq '$#' ) {
  22785.  
  22786.                     if ( $tok eq '{' ) { $type = 'i'; $i = $i_save }
  22787.  
  22788.                     # perl seems to allow just these: $#: $#- $#+
  22789.                     elsif ( $tok =~ /^[\:\-\+]$/ ) {
  22790.                         $type = 'i';
  22791.                         $identifier .= $tok;
  22792.                     }
  22793.                     else {
  22794.                         $i = $i_save;
  22795.                         write_logfile_entry( 'Use of $# is deprecated' . "\n" );
  22796.                     }
  22797.                 }
  22798.                 elsif ( $identifier eq '$$' ) {
  22799.  
  22800.                     # perl does not allow references to punctuation
  22801.                     # variables without braces.  For example, this
  22802.                     # won't work:
  22803.                     #  $:=\4;
  22804.                     #  $a = $$:;
  22805.                     # You would have to use
  22806.                     #  $a = ${$:};
  22807.  
  22808.                     $i = $i_save;
  22809.                     if ( $tok eq '{' ) { $type = 't' }
  22810.                     else { $type = 'i' }
  22811.                 }
  22812.                 elsif ( $identifier eq '->' ) {
  22813.                     $i = $i_save;
  22814.                 }
  22815.                 else {
  22816.                     $i = $i_save;
  22817.                     if ( length($identifier) == 1 ) { $identifier = ''; }
  22818.                 }
  22819.                 $id_scan_state = '';
  22820.                 last;
  22821.             }
  22822.         }
  22823.         elsif ( $id_scan_state eq '&' ) {    # starting sub call?
  22824.  
  22825.             if ( $tok =~ /^[\$A-Za-z_]/ ) {    # alphanumeric ..
  22826.                 $id_scan_state = ':';          # now need ::
  22827.                 $saw_alpha     = 1;
  22828.                 $identifier .= $tok;
  22829.             }
  22830.             elsif ( $tok eq "'" && $allow_tick ) {    # alphanumeric ..
  22831.                 $id_scan_state = ':';                 # now need ::
  22832.                 $saw_alpha     = 1;
  22833.                 $identifier .= $tok;
  22834.             }
  22835.             elsif ( $tok =~ /^[0-9]/ ) {    # numeric..see comments above
  22836.                 $id_scan_state = ':';       # now need ::
  22837.                 $saw_alpha     = 1;
  22838.                 $identifier .= $tok;
  22839.             }
  22840.             elsif ( $tok =~ /^\s*$/ ) {     # allow space
  22841.             }
  22842.             elsif ( $tok eq '::' ) {        # leading ::
  22843.                 $id_scan_state = 'A';       # accept alpha next
  22844.                 $identifier .= $tok;
  22845.             }
  22846.             elsif ( $tok eq '{' ) {
  22847.                 if ( $identifier eq '&' || $i == 0 ) { $identifier = ''; }
  22848.                 $i             = $i_save;
  22849.                 $id_scan_state = '';
  22850.                 last;
  22851.             }
  22852.             else {
  22853.  
  22854.                 # punctuation variable?
  22855.                 # testfile: cunningham4.pl
  22856.                 if ( $identifier eq '&' ) {
  22857.                     $identifier .= $tok;
  22858.                 }
  22859.                 else {
  22860.                     $identifier = '';
  22861.                     $i          = $i_save;
  22862.                     $type       = '&';
  22863.                 }
  22864.                 $id_scan_state = '';
  22865.                 last;
  22866.             }
  22867.         }
  22868.         elsif ( $id_scan_state eq 'A' ) {    # looking for alpha (after ::)
  22869.  
  22870.             if ( $tok =~ /^[A-Za-z_]/ ) {    # found it
  22871.                 $identifier .= $tok;
  22872.                 $id_scan_state = ':';        # now need ::
  22873.                 $saw_alpha     = 1;
  22874.             }
  22875.             elsif ( $tok eq "'" && $allow_tick ) {
  22876.                 $identifier .= $tok;
  22877.                 $id_scan_state = ':';        # now need ::
  22878.                 $saw_alpha     = 1;
  22879.             }
  22880.             elsif ( $tok =~ /^[0-9]/ ) {     # numeric..see comments above
  22881.                 $identifier .= $tok;
  22882.                 $id_scan_state = ':';        # now need ::
  22883.                 $saw_alpha     = 1;
  22884.             }
  22885.             elsif ( ( $identifier =~ /^sub / ) && ( $tok =~ /^\s*$/ ) ) {
  22886.                 $id_scan_state = '(';
  22887.                 $identifier .= $tok;
  22888.             }
  22889.             elsif ( ( $identifier =~ /^sub / ) && ( $tok eq '(' ) ) {
  22890.                 $id_scan_state = ')';
  22891.                 $identifier .= $tok;
  22892.             }
  22893.             else {
  22894.                 $id_scan_state = '';
  22895.                 $i             = $i_save;
  22896.                 last;
  22897.             }
  22898.         }
  22899.         elsif ( $id_scan_state eq ':' ) {    # looking for :: after alpha
  22900.  
  22901.             if ( $tok eq '::' ) {            # got it
  22902.                 $identifier .= $tok;
  22903.                 $id_scan_state = 'A';        # now require alpha
  22904.             }
  22905.             elsif ( $tok =~ /^[A-Za-z_]/ ) {    # more alphanumeric is ok here
  22906.                 $identifier .= $tok;
  22907.                 $id_scan_state = ':';           # now need ::
  22908.                 $saw_alpha     = 1;
  22909.             }
  22910.             elsif ( $tok =~ /^[0-9]/ ) {        # numeric..see comments above
  22911.                 $identifier .= $tok;
  22912.                 $id_scan_state = ':';           # now need ::
  22913.                 $saw_alpha     = 1;
  22914.             }
  22915.             elsif ( $tok eq "'" && $allow_tick ) {    # tick
  22916.  
  22917.                 if ( $is_keyword{$identifier} ) {
  22918.                     $id_scan_state = '';              # that's all
  22919.                     $i             = $i_save;
  22920.                 }
  22921.                 else {
  22922.                     $identifier .= $tok;
  22923.                 }
  22924.             }
  22925.             elsif ( ( $identifier =~ /^sub / ) && ( $tok =~ /^\s*$/ ) ) {
  22926.                 $id_scan_state = '(';
  22927.                 $identifier .= $tok;
  22928.             }
  22929.             elsif ( ( $identifier =~ /^sub / ) && ( $tok eq '(' ) ) {
  22930.                 $id_scan_state = ')';
  22931.                 $identifier .= $tok;
  22932.             }
  22933.             else {
  22934.                 $id_scan_state = '';        # that's all
  22935.                 $i             = $i_save;
  22936.                 last;
  22937.             }
  22938.         }
  22939.         elsif ( $id_scan_state eq '(' ) {    # looking for ( of prototype
  22940.  
  22941.             if ( $tok eq '(' ) {             # got it
  22942.                 $identifier .= $tok;
  22943.                 $id_scan_state = ')';        # now find the end of it
  22944.             }
  22945.             elsif ( $tok =~ /^\s*$/ ) {      # blank - keep going
  22946.                 $identifier .= $tok;
  22947.             }
  22948.             else {
  22949.                 $id_scan_state = '';         # that's all - no prototype
  22950.                 $i             = $i_save;
  22951.                 last;
  22952.             }
  22953.         }
  22954.         elsif ( $id_scan_state eq ')' ) {    # looking for ) to end
  22955.  
  22956.             if ( $tok eq ')' ) {             # got it
  22957.                 $identifier .= $tok;
  22958.                 $id_scan_state = '';         # all done
  22959.                 last;
  22960.             }
  22961.             elsif ( $tok =~ /^[\s\$\%\\\*\@\&\;]/ ) {
  22962.                 $identifier .= $tok;
  22963.             }
  22964.             else {    # probable error in script, but keep going
  22965.                 warning("Unexpected '$tok' while seeking end of prototype\n");
  22966.                 $identifier .= $tok;
  22967.             }
  22968.         }
  22969.         else {        # can get here due to error in initialization
  22970.             $id_scan_state = '';
  22971.             $i             = $i_save;
  22972.             last;
  22973.         }
  22974.     }
  22975.  
  22976.     if ( $id_scan_state eq ')' ) {
  22977.         warning("Hit end of line while seeking ) to end prototype\n");
  22978.     }
  22979.  
  22980.     # once we enter the actual identifier, it may not extend beyond
  22981.     # the end of the current line
  22982.     if ( $id_scan_state =~ /^[A\:\(\)]/ ) {
  22983.         $id_scan_state = '';
  22984.     }
  22985.     if ( $i < 0 ) { $i = 0 }
  22986.  
  22987.     unless ($type) {
  22988.  
  22989.         if ($saw_type) {
  22990.  
  22991.             if ($saw_alpha) {
  22992.                 $type = 'i';
  22993.             }
  22994.             elsif ( $identifier eq '->' ) {
  22995.                 $type = '->';
  22996.             }
  22997.             elsif (
  22998.                 ( length($identifier) > 1 )
  22999.  
  23000.                 # In something like '@$=' we have an identifier '@$'
  23001.                 # In something like '$${' we have type '$$' (and only
  23002.                 # part of an identifier)
  23003.                 && !( $identifier =~ /\$$/ && $tok eq '{' )
  23004.                 && ( $identifier !~ /^(sub |package )$/ )
  23005.               )
  23006.             {
  23007.                 $type = 'i';
  23008.             }
  23009.             else { $type = 't' }
  23010.         }
  23011.         elsif ($saw_alpha) {
  23012.  
  23013.             # type 'w' includes anything without leading type info
  23014.             # ($,%,@,*) including something like abc::def::ghi
  23015.             $type = 'w';
  23016.         }
  23017.         else {
  23018.             $type = '';
  23019.         }    # this can happen on a restart
  23020.     }
  23021.  
  23022.     if ($identifier) {
  23023.         $tok = $identifier;
  23024.         if ($message) { write_logfile_entry($message) }
  23025.     }
  23026.     else {
  23027.         $tok = $tok_begin;
  23028.         $i   = $i_begin;
  23029.     }
  23030.  
  23031.     TOKENIZER_DEBUG_FLAG_SCAN_ID && do {
  23032.         my ( $a, $b, $c ) = caller;
  23033.         print
  23034. "SCANID: called from $a $b $c with tok, i, state, identifier =$tok_begin, $i_begin, $id_scan_state_begin, $identifier_begin\n";
  23035.         print
  23036. "SCANID: returned with tok, i, state, identifier =$tok, $i, $id_scan_state, $identifier\n";
  23037.     };
  23038.     return ( $i, $tok, $type, $id_scan_state, $identifier );
  23039. }
  23040.  
  23041. sub follow_quoted_string {
  23042.  
  23043.     # scan for a specific token, skipping escaped characters
  23044.     # if the quote character is blank, use the first non-blank character
  23045.     # input parameters:
  23046.     #   $rtokens = reference to the array of tokens
  23047.     #   $i = the token index of the first character to search
  23048.     #   $in_quote = number of quoted strings being followed
  23049.     #   $beginning_tok = the starting quote character
  23050.     #   $quote_pos = index to check next for alphanumeric delimiter
  23051.     # output parameters:
  23052.     #   $i = the token index of the ending quote character
  23053.     #   $in_quote = decremented if found end, unchanged if not
  23054.     #   $beginning_tok = the starting quote character
  23055.     #   $quote_pos = index to check next for alphanumeric delimiter
  23056.     #   $quote_depth = nesting depth, since delimiters '{ ( [ <' can be nested.
  23057.     my ( $i_beg, $in_quote, $rtokens, $beginning_tok, $quote_pos, $quote_depth )
  23058.       = @_;
  23059.     my ( $tok, $end_tok );
  23060.     my $i = $i_beg - 1;
  23061.  
  23062.     TOKENIZER_DEBUG_FLAG_QUOTE && do {
  23063.         print
  23064. "QUOTE entering with quote_pos = $quote_pos i=$i beginning_tok =$beginning_tok\n";
  23065.     };
  23066.  
  23067.     # get the corresponding end token
  23068.     if ( $beginning_tok !~ /^\s*$/ ) {
  23069.         $end_tok = matching_end_token($beginning_tok);
  23070.     }
  23071.  
  23072.     # a blank token means we must find and use the first non-blank one
  23073.     else {
  23074.         my $allow_quote_comments = ( $i < 0 ) ? 1 : 0; # i<0 means we saw a <cr>
  23075.  
  23076.         while ( $i < $max_token_index ) {
  23077.             $tok = $$rtokens[ ++$i ];
  23078.  
  23079.             if ( $tok !~ /^\s*$/ ) {
  23080.  
  23081.                 if ( ( $tok eq '#' ) && ($allow_quote_comments) ) {
  23082.                     $i = $max_token_index;
  23083.                 }
  23084.                 else {
  23085.  
  23086.                     if ( length($tok) > 1 ) {
  23087.                         if ( $quote_pos <= 0 ) { $quote_pos = 1 }
  23088.                         $beginning_tok = substr( $tok, $quote_pos - 1, 1 );
  23089.                     }
  23090.                     else {
  23091.                         $beginning_tok = $tok;
  23092.                         $quote_pos     = 0;
  23093.                     }
  23094.                     $end_tok     = matching_end_token($beginning_tok);
  23095.                     $quote_depth = 1;
  23096.                     last;
  23097.                 }
  23098.             }
  23099.             else {
  23100.                 $allow_quote_comments = 1;
  23101.             }
  23102.         }
  23103.     }
  23104.  
  23105.     # There are two different loops which search for the ending quote
  23106.     # character.  In the rare case of an alphanumeric quote delimiter, we
  23107.     # have to look through alphanumeric tokens character-by-character, since
  23108.     # the pre-tokenization process combines multiple alphanumeric
  23109.     # characters, whereas for a non-alphanumeric delimiter, only tokens of
  23110.     # length 1 can match.
  23111.  
  23112.     # loop for case of alphanumeric quote delimiter..
  23113.     # "quote_pos" is the position the current word to begin searching
  23114.     if ( $beginning_tok =~ /\w/ ) {
  23115.  
  23116.         # Note this because it is not recommended practice except
  23117.         # for obfuscated perl contests
  23118.         if ( $in_quote == 1 ) {
  23119.             write_logfile_entry(
  23120.                 "Note: alphanumeric quote delimiter ($beginning_tok) \n");
  23121.         }
  23122.  
  23123.         while ( $i < $max_token_index ) {
  23124.  
  23125.             if ( $quote_pos == 0 || ( $i < 0 ) ) {
  23126.                 $tok = $$rtokens[ ++$i ];
  23127.  
  23128.                 if ( $tok eq '\\' ) {
  23129.  
  23130.                     $quote_pos++;
  23131.                     last if ( $i >= $max_token_index );
  23132.                     $tok = $$rtokens[ ++$i ];
  23133.  
  23134.                 }
  23135.             }
  23136.             my $old_pos = $quote_pos;
  23137.  
  23138.             unless ( defined($tok) && defined($end_tok) && defined($quote_pos) )
  23139.             {
  23140.  
  23141.             }
  23142.             $quote_pos = 1 + index( $tok, $end_tok, $quote_pos );
  23143.  
  23144.             if ( $quote_pos > 0 ) {
  23145.  
  23146.                 $quote_depth--;
  23147.  
  23148.                 if ( $quote_depth == 0 ) {
  23149.                     $in_quote--;
  23150.                     last;
  23151.                 }
  23152.             }
  23153.         }
  23154.     }
  23155.  
  23156.     # loop for case of a non-alphanumeric quote delimiter..
  23157.     else {
  23158.  
  23159.         while ( $i < $max_token_index ) {
  23160.             $tok = $$rtokens[ ++$i ];
  23161.  
  23162.             if ( $tok eq $end_tok ) {
  23163.                 $quote_depth--;
  23164.  
  23165.                 if ( $quote_depth == 0 ) {
  23166.                     $in_quote--;
  23167.                     last;
  23168.                 }
  23169.             }
  23170.             elsif ( $tok eq $beginning_tok ) {
  23171.                 $quote_depth++;
  23172.             }
  23173.             elsif ( $tok eq '\\' ) {
  23174.                 $i++;
  23175.             }
  23176.         }
  23177.     }
  23178.     if ( $i > $max_token_index ) { $i = $max_token_index }
  23179.     return ( $i, $in_quote, $beginning_tok, $quote_pos, $quote_depth );
  23180. }
  23181.  
  23182. sub matching_end_token {
  23183.  
  23184.     # find closing character for a pattern
  23185.     my $beginning_token = shift;
  23186.  
  23187.     if ( $beginning_token eq '{' ) {
  23188.         '}';
  23189.     }
  23190.     elsif ( $beginning_token eq '[' ) {
  23191.         ']';
  23192.     }
  23193.     elsif ( $beginning_token eq '<' ) {
  23194.         '>';
  23195.     }
  23196.     elsif ( $beginning_token eq '(' ) {
  23197.         ')';
  23198.     }
  23199.     else {
  23200.         $beginning_token;
  23201.     }
  23202. }
  23203.  
  23204. BEGIN {
  23205.  
  23206.     # These names are used in error messages
  23207.     @opening_brace_names = qw# '{' '[' '(' '?' #;
  23208.     @closing_brace_names = qw# '}' ']' ')' ':' #;
  23209.  
  23210.     my @digraphs = qw(
  23211.       .. :: << >> ** && .. ||  -> => += -= .= %= &= |= ^= *= <>
  23212.       <= >= == =~ !~ != ++ -- /= x=
  23213.     );
  23214.     @is_digraph{@digraphs} = (1) x scalar(@digraphs);
  23215.  
  23216.     my @trigraphs = qw( ... **= <<= >>= &&= ||= <=> );
  23217.     @is_trigraph{@trigraphs} = (1) x scalar(@trigraphs);
  23218.  
  23219.     # make a hash of all valid token types for self-checking the tokenizer
  23220.     # (adding NEW_TOKENS : select a new character and add to this list)
  23221.     my @valid_token_types = qw#
  23222.       A b C G L R f h Q k t w i q n p m F pp mm U j J Y Z v
  23223.       { } ( ) [ ] ; + - / * | % ! x ~ = \ ? : . < > ^ &
  23224.       #;
  23225.     push ( @valid_token_types, @digraphs );
  23226.     push ( @valid_token_types, @trigraphs );
  23227.     push ( @valid_token_types, '#' );
  23228.     push ( @valid_token_types, ',' );
  23229.     @is_valid_token_type{@valid_token_types} = (1) x scalar(@valid_token_types);
  23230.  
  23231.     # a list of file test letters, as in -e (Table 3-4 of 'camel 3')
  23232.     my @file_test_operators =
  23233.       qw( A B C M O R S T W X b c d e f g k l o p r s t u w x z);
  23234.     @is_file_test_operator{@file_test_operators} =
  23235.       (1) x scalar(@file_test_operators);
  23236.  
  23237.     # these functions have prototypes of the form (&), so when they are
  23238.     # followed by a block, that block MAY BE followed by an operator.
  23239.     @_ = qw( do eval );
  23240.     @is_block_operator{@_} = (1) x scalar(@_);
  23241.  
  23242.     # these functions allow an identifier in the indirect object slot
  23243.     @_ = qw( print printf sort exec system );
  23244.     @is_indirect_object_taker{@_} = (1) x scalar(@_);
  23245.  
  23246.     # These tokens may precede a code block
  23247.     # patched for SWITCH/CASE
  23248.     @_ = qw( BEGIN END CHECK INIT AUTOLOAD DESTROY continue if elsif else
  23249.       unless do while until eval for foreach map grep sort
  23250.       switch case given when);
  23251.     @is_code_block_token{@_} = (1) x scalar(@_);
  23252.  
  23253.     # I'll build the list of keywords incrementally
  23254.     my @Keywords = ();
  23255.  
  23256.     # keywords and tokens after which a value or pattern is expected,
  23257.     # but not an operator.  In other words, these should consume terms
  23258.     # to their right, or at least they are not expected to be followed
  23259.     # immediately by operators.
  23260.     my @value_requestor = qw(
  23261.       AUTOLOAD
  23262.       BEGIN
  23263.       CHECK
  23264.       DESTROY
  23265.       END
  23266.       EQ
  23267.       GE
  23268.       GT
  23269.       INIT
  23270.       LE
  23271.       LT
  23272.       NE
  23273.       abs
  23274.       accept
  23275.       alarm
  23276.       and
  23277.       atan2
  23278.       bind
  23279.       binmode
  23280.       bless
  23281.       caller
  23282.       chdir
  23283.       chmod
  23284.       chomp
  23285.       chop
  23286.       chown
  23287.       chr
  23288.       chroot
  23289.       close
  23290.       closedir
  23291.       cmp
  23292.       connect
  23293.       continue
  23294.       cos
  23295.       crypt
  23296.       dbmclose
  23297.       dbmopen
  23298.       defined
  23299.       delete
  23300.       die
  23301.       dump
  23302.       each
  23303.       else
  23304.       elsif
  23305.       eof
  23306.       eq
  23307.       exec
  23308.       exists
  23309.       exit
  23310.       exp
  23311.       fcntl
  23312.       fileno
  23313.       flock
  23314.       for
  23315.       foreach
  23316.       formline
  23317.       ge
  23318.       getc
  23319.       getgrgid
  23320.       getgrnam
  23321.       gethostbyaddr
  23322.       gethostbyname
  23323.       getnetbyaddr
  23324.       getnetbyname
  23325.       getpeername
  23326.       getpgrp
  23327.       getpriority
  23328.       getprotobyname
  23329.       getprotobynumber
  23330.       getpwnam
  23331.       getpwuid
  23332.       getservbyname
  23333.       getservbyport
  23334.       getsockname
  23335.       getsockopt
  23336.       glob
  23337.       gmtime
  23338.       goto
  23339.       grep
  23340.       gt
  23341.       hex
  23342.       if
  23343.       index
  23344.       int
  23345.       ioctl
  23346.       join
  23347.       keys
  23348.       kill
  23349.       last
  23350.       lc
  23351.       lcfirst
  23352.       le
  23353.       length
  23354.       link
  23355.       listen
  23356.       local
  23357.       localtime
  23358.       lock
  23359.       log
  23360.       lstat
  23361.       lt
  23362.       map
  23363.       mkdir
  23364.       msgctl
  23365.       msgget
  23366.       msgrcv
  23367.       msgsnd
  23368.       my
  23369.       ne
  23370.       next
  23371.       no
  23372.       not
  23373.       oct
  23374.       open
  23375.       opendir
  23376.       or
  23377.       ord
  23378.       our
  23379.       pack
  23380.       pipe
  23381.       pop
  23382.       pos
  23383.       print
  23384.       printf
  23385.       prototype
  23386.       push
  23387.       quotemeta
  23388.       rand
  23389.       read
  23390.       readdir
  23391.       readlink
  23392.       readline
  23393.       readpipe
  23394.       recv
  23395.       redo
  23396.       ref
  23397.       rename
  23398.       require
  23399.       reset
  23400.       return
  23401.       reverse
  23402.       rewinddir
  23403.       rindex
  23404.       rmdir
  23405.       scalar
  23406.       seek
  23407.       seekdir
  23408.       select
  23409.       semctl
  23410.       semget
  23411.       semop
  23412.       send
  23413.       sethostent
  23414.       setnetent
  23415.       setpgrp
  23416.       setpriority
  23417.       setprotoent
  23418.       setservent
  23419.       setsockopt
  23420.       shift
  23421.       shmctl
  23422.       shmget
  23423.       shmread
  23424.       shmwrite
  23425.       shutdown
  23426.       sin
  23427.       sleep
  23428.       socket
  23429.       socketpair
  23430.       sort
  23431.       splice
  23432.       split
  23433.       sprintf
  23434.       sqrt
  23435.       srand
  23436.       stat
  23437.       study
  23438.       substr
  23439.       symlink
  23440.       syscall
  23441.       sysopen
  23442.       sysread
  23443.       sysseek
  23444.       system
  23445.       syswrite
  23446.       tell
  23447.       telldir
  23448.       tie
  23449.       tied
  23450.       truncate
  23451.       uc
  23452.       ucfirst
  23453.       umask
  23454.       undef
  23455.       unless
  23456.       unlink
  23457.       unpack
  23458.       unshift
  23459.       untie
  23460.       until
  23461.       use
  23462.       utime
  23463.       values
  23464.       vec
  23465.       waitpid
  23466.       warn
  23467.       while
  23468.       write
  23469.       xor
  23470.  
  23471.       switch
  23472.       case
  23473.       given
  23474.       when
  23475.     );
  23476.  
  23477.     # patched above for SWITCH/CASE
  23478.     push ( @Keywords, @value_requestor );
  23479.  
  23480.     # These are treated the same but are not keywords:
  23481.     my @extra_vr = qw(
  23482.       constant
  23483.       vars
  23484.     );
  23485.     push ( @value_requestor, @extra_vr );
  23486.  
  23487.     @expecting_term_token{@value_requestor} = (1) x scalar(@value_requestor);
  23488.  
  23489.     # this list contains keywords which do not look for arguments,
  23490.     # so that they might be followed by an operator, or at least
  23491.     # not a term.
  23492.     my @operator_requestor = qw(
  23493.       endgrent
  23494.       endhostent
  23495.       endnetent
  23496.       endprotoent
  23497.       endpwent
  23498.       endservent
  23499.       fork
  23500.       getgrent
  23501.       gethostent
  23502.       getlogin
  23503.       getnetent
  23504.       getppid
  23505.       getprotoent
  23506.       getpwent
  23507.       getservent
  23508.       setgrent
  23509.       setpwent
  23510.       time
  23511.       times
  23512.       wait
  23513.       wantarray
  23514.     );
  23515.  
  23516.     push ( @Keywords, @operator_requestor );
  23517.  
  23518.     # These are treated the same but are not considered keywords:
  23519.     my @extra_or = qw(
  23520.       STDERR
  23521.       STDIN
  23522.       STDOUT
  23523.     );
  23524.  
  23525.     push ( @operator_requestor, @extra_or );
  23526.  
  23527.     @expecting_operator_token{@operator_requestor} =
  23528.       (1) x scalar(@operator_requestor);
  23529.  
  23530.     # these token TYPES expect trailing operator but not a term
  23531.     # note: ++ and -- are post-increment and decrement, 'C' = constant
  23532.     my @operator_requestor_types = qw( ++ -- C );
  23533.     @expecting_operator_types{@operator_requestor_types} =
  23534.       (1) x scalar(@operator_requestor_types);
  23535.  
  23536.     # these token TYPES consume values (terms)
  23537.     # note: pp and mm are pre-increment and decrement
  23538.     # f=semicolon in for,  F=file test operator
  23539.     my @value_requestor_type = qw#
  23540.       L { ( [ ~ !~ =~ ; . .. ... A : && ! || = + - x
  23541.       **= += -= .= /= *= %= x= &= |= ^= <<= >>= &&= ||=
  23542.       <= >= == != => \ > < % * / ? & | ** <=>
  23543.       f F pp mm Y p m U J G
  23544.       #;
  23545.     push ( @value_requestor_type, ',' )
  23546.       ;    # (perl doesn't like a ',' in a qw block)
  23547.     @expecting_term_types{@value_requestor_type} =
  23548.       (1) x scalar(@value_requestor_type);
  23549.  
  23550.     # For simple syntax checking, it is nice to have a list of operators which
  23551.     # will really be unhappy if not followed by a term.  This includes most
  23552.     # of the above...
  23553.     %really_want_term = %expecting_term_types;
  23554.  
  23555.     # with these exceptions...
  23556.     delete $really_want_term{'U'}; # user sub, depends on prototype
  23557.     delete $really_want_term{'F'}; # file test works on $_ if no following term
  23558.     delete $really_want_term{'Y'}; # indirect object, too risky to check syntax;
  23559.                                    # let perl do it
  23560.  
  23561.     # These keywords are handled specially in the tokenizer code:
  23562.     my @special_keywords = qw(
  23563.       do
  23564.       eval
  23565.       format
  23566.       m
  23567.       package
  23568.       q
  23569.       qq
  23570.       qr
  23571.       qw
  23572.       qx
  23573.       s
  23574.       sub
  23575.       tr
  23576.       y
  23577.     );
  23578.     push ( @Keywords, @special_keywords );
  23579.  
  23580.     # Keywords after which list formatting may be used
  23581.     # WARNING: do not include |map|grep|eval or perl may die on
  23582.     # syntax errors (map1.t).
  23583.     my @keyword_taking_list = qw(
  23584.       and
  23585.       chmod
  23586.       chomp
  23587.       chop
  23588.       chown
  23589.       dbmopen
  23590.       die
  23591.       elsif
  23592.       exec
  23593.       fcntl
  23594.       for
  23595.       foreach
  23596.       formline
  23597.       getsockopt
  23598.       if
  23599.       index
  23600.       ioctl
  23601.       join
  23602.       kill
  23603.       local
  23604.       msgctl
  23605.       msgrcv
  23606.       msgsnd
  23607.       my
  23608.       open
  23609.       or
  23610.       our
  23611.       pack
  23612.       print
  23613.       printf
  23614.       push
  23615.       read
  23616.       readpipe
  23617.       recv
  23618.       return
  23619.       reverse
  23620.       rindex
  23621.       seek
  23622.       select
  23623.       semctl
  23624.       semget
  23625.       send
  23626.       setpriority
  23627.       setsockopt
  23628.       shmctl
  23629.       shmget
  23630.       shmread
  23631.       shmwrite
  23632.       socket
  23633.       socketpair
  23634.       sort
  23635.       splice
  23636.       split
  23637.       sprintf
  23638.       substr
  23639.       syscall
  23640.       sysopen
  23641.       sysread
  23642.       sysseek
  23643.       system
  23644.       syswrite
  23645.       tie
  23646.       unless
  23647.       unlink
  23648.       unpack
  23649.       unshift
  23650.       until
  23651.       vec
  23652.       warn
  23653.       while
  23654.     );
  23655.     @is_keyword_taking_list{@keyword_taking_list} =
  23656.       (1) x scalar(@keyword_taking_list);
  23657.  
  23658.     # These are not used in any way yet
  23659.     #    my @unused_keywords = qw(
  23660.     #      CORE
  23661.     #     __FILE__
  23662.     #     __LINE__
  23663.     #     __PACKAGE__
  23664.     #     );
  23665.  
  23666.     #  The list of keywords was extracted from function 'keyword' in
  23667.     #  perl file toke.c version 5.005.03, using this utility, plus a
  23668.     #  little editing: (file getkwd.pl):
  23669.     #  while (<>) { while (/\"(.*)\"/g) { print "$1\n"; } }
  23670.     #  Add 'get' prefix where necessary, then split into the above lists.
  23671.     #  This list should be updated as necessary.
  23672.     #  The list should not contain these special variables:
  23673.     #  ARGV DATA ENV SIG STDERR STDIN STDOUT
  23674.     #  __DATA__ __END__
  23675.  
  23676.     @is_keyword{@Keywords} = (1) x scalar(@Keywords);
  23677. }
  23678. 1;
  23679. __END__
  23680.  
  23681. =head1 NAME
  23682.  
  23683. Perl::Tidy - main module for the perltidy utility
  23684.  
  23685. =head1 SYNOPSIS
  23686.  
  23687.     use Perl::Tidy;
  23688.  
  23689.     Perl::Tidy::perltidy(
  23690.         source      => $source,
  23691.         destination => $destination,
  23692.         stderr      => $stderr,
  23693.         argv        => $argv,
  23694.         perltidyrc  => $perltidyrc,
  23695.         logfile     => $logfile,
  23696.         errorfile   => $errorfile,
  23697.     );
  23698.  
  23699. =head1 DESCRIPTION
  23700.  
  23701. This module makes the functionality of the perltidy utility available to perl
  23702. scripts.  Any or all of the input parameters may be omitted, in which case the
  23703. @ARGV array will be used to provide input parameters as described
  23704. in the perltidy(1) man page.
  23705.  
  23706. For example, the perltidy script is basically just this:
  23707.  
  23708.     use Perl::Tidy;
  23709.     Perl::Tidy::perltidy();
  23710.  
  23711. The module accepts input and output streams by a variety of methods.
  23712. The following list of parameters may be any of a the following: a
  23713. filename, an ARRAY reference, a SCALAR reference, or an object with
  23714. either a B<getline> or B<print> method, as appropriate.
  23715.  
  23716.         source          - the source of the script to be formatted
  23717.         destination     - the destination of the formatted output
  23718.         stderr          - standard error output
  23719.         perltidyrc      - the .perltidyrc file
  23720.         logfile         - the .LOG file stream, if any 
  23721.         errorfile       - the .ERR file stream, if any
  23722.  
  23723. The following chart illustrates the logic used to decide how to
  23724. treat a parameter.
  23725.  
  23726.    ref($param)  $param is assumed to be:
  23727.    -----------  ---------------------
  23728.    undef        a filename
  23729.    SCALAR       ref to string
  23730.    ARRAY        ref to array
  23731.    (other)      object with getline (if source) or print method
  23732.  
  23733. If the parameter is an object, and the object has a B<close> method, that
  23734. close method will be called at the end of the stream.
  23735.  
  23736. =over 4
  23737.  
  23738. =item source
  23739.  
  23740. If the B<source> parameter is given, it defines the source of the
  23741. input stream.
  23742.  
  23743. =item destination
  23744.  
  23745. If the B<destination> parameter is given, it will be used to define the
  23746. file or memory location to receive output of perltidy.  
  23747.  
  23748. =item stderr
  23749.  
  23750. The B<stderr> parameter allows the calling program to capture the output
  23751. to what would otherwise go to the standard error output device.
  23752.  
  23753. =item perltidyrc
  23754.  
  23755. If the B<perltidyrc> file is given, it will be used instead of any
  23756. F<.perltidyrc> configuration file that would otherwise be used. 
  23757.  
  23758. =item argv
  23759.  
  23760. If the B<argv> parameter is given, it will be used instead of the
  23761. B<@ARGV> array.  The B<argv> parameter may be a string, a reference to a
  23762. string, or a reference to an array.  If it is a string or reference to a
  23763. string, it will be parsed into an array of items just as if it were a
  23764. command line string.
  23765.  
  23766. =back
  23767.  
  23768. =head1 EXAMPLE
  23769.  
  23770. The following example passes perltidy a snippet as a reference
  23771. to a string and receives the result back in a reference to
  23772. an array.  
  23773.  
  23774.  use Perl::Tidy;
  23775.  
  23776.  # some messy source code to format
  23777.  my $source = <<'EOM';
  23778.  use strict;
  23779.  my @editors=('Emacs', 'Vi   '); my $rand = rand();
  23780.  print "A poll of 10 random programmers gave these results:\n";
  23781.  foreach(0..10) {
  23782.  my $i=int ($rand+rand());
  23783.  print " $editors[$i] users are from Venus" . ", " . 
  23784.  "$editors[1-$i] users are from Mars" . 
  23785.  "\n";
  23786.  }
  23787.  EOM
  23788.  
  23789.  # We'll pass it as ref to SCALAR and receive it in a ref to ARRAY
  23790.  my @dest;
  23791.  perltidy( source => \$source, destination => \@dest );
  23792.  foreach (@dest) {print}
  23793.  
  23794. =head1 EXPORT
  23795.  
  23796.   &perltidy
  23797.  
  23798. =head1 CREDITS
  23799.  
  23800. Thanks to Hugh Myers who developed the initial modular interface 
  23801. to perltidy.
  23802.  
  23803. =head1 VERSION
  23804.  
  23805. This man page documents Perl::Tidy version 20021130.
  23806.  
  23807. =head1 AUTHOR
  23808.  
  23809.  Steve Hancock
  23810.  perltidy at users.sourceforge.net
  23811.  
  23812. =head1 SEE ALSO
  23813.  
  23814. The perltidy(1) man page describes all of the features of perltidy.  It
  23815. can be found at http://perltidy.sourceforge.net.
  23816.  
  23817. =cut
  23818.